From b7ebf46e66a05a67d803c4f7c4fa984742648e3a Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Tue, 3 Dec 2024 10:56:18 +0100 Subject: [PATCH 001/112] Add thunks to CakeML source semantics --- semantics/astScript.sml | 11 +++++++ semantics/evaluateScript.sml | 42 ++++++++++++++++++++++++-- semantics/semanticPrimitivesScript.sml | 21 +++++++++++-- 3 files changed, 69 insertions(+), 5 deletions(-) diff --git a/semantics/astScript.sml b/semantics/astScript.sml index b8e3592646..a9630ff262 100644 --- a/semantics/astScript.sml +++ b/semantics/astScript.sml @@ -54,6 +54,13 @@ Datatype: word_size = W8 | W64 End +Datatype: + thunk_op = + AllocThunk bool + | UpdateThunk bool + | ForceThunk +End + Datatype: op = (* Operations on integers *) @@ -122,6 +129,8 @@ Datatype: | Aupdate_unsafe | Aw8sub_unsafe | Aw8update_unsafe + (* thunk operations *) + | ThunkOp thunk_op (* List operations *) | ListAppend (* Configure the GC *) @@ -139,6 +148,7 @@ Datatype: op_class = EvalOp (* Eval primitive *) | FunApp (* function application *) + | Force (* forcing a thunk *) | Simple (* arithmetic operation, no finite-precision/reals *) | Icing (* 64-bit floating-points *) | Reals (* real numbers *) @@ -156,6 +166,7 @@ Definition getOpClass_def[simp]: | RealFromFP => Reals | Opapp => FunApp | Eval => EvalOp + | ThunkOp t => (if t = ForceThunk then Force else Simple) | _ => Simple End diff --git a/semantics/evaluateScript.sml b/semantics/evaluateScript.sml index 7e8a0a65c6..2e30124827 100644 --- a/semantics/evaluateScript.sml +++ b/semantics/evaluateScript.sml @@ -55,6 +55,29 @@ Definition do_real_check_def: | _ => SOME r)) End +Definition dest_thunk_def: + dest_thunk [Loc _ n] st = + (case store_lookup n st of + | SOME (Thunk T v) => SOME (INL v) + | SOME (Thunk F v) => SOME (INR v) + | _ => NONE) ∧ + dest_thunk vs st = NONE +End + +Definition update_thunk_def: + update_thunk [Loc _ n] st [v] = store_assign n (Thunk T v) st ∧ + update_thunk _ st _ = NONE +End + +Definition sing_env_def: + sing_env n v = + <| v := nsBind n v nsEmpty; c := nsEmpty |> : v sem_env +End + +Definition AppUnit_def: + AppUnit e = App Opapp [e; Con NONE []] +End + Definition evaluate_def[nocompute]: evaluate st env [] = ((st:'ffi state),Rval []) ∧ @@ -106,13 +129,28 @@ Definition evaluate_def[nocompute]: FunApp => (case do_opapp (REVERSE vs) of SOME (env',e) => - if st'.clock =( 0 : num) then + if st'.clock = 0 then (st', Rerr (Rabort Rtimeout_error)) else evaluate (dec_clock st') env' [e] | NONE => (st', Rerr (Rabort Rtype_error)) ) - |EvalOp => + | Force => + (case dest_thunk vs st'.refs of + | NONE => (st', Rerr (Rabort Rtype_error)) + | SOME (INL v) => (st', Rval [v]) + | SOME (INR f) => + if st'.clock = 0 then + (st', Rerr (Rabort Rtimeout_error)) + else + case evaluate (dec_clock st') (sing_env "f" f) + [AppUnit (Var (Short "f"))] of + | (st2, Rval vs2) => + (case update_thunk vs st2.refs vs2 of + | NONE => (st2, Rerr (Rabort Rtype_error)) + | SOME refs => (st2 with refs := refs, Rval vs2)) + | (st2, Rerr e) => (st2, Rerr e)) + | EvalOp => (case fix_clock st' (do_eval_res (REVERSE vs) st') of (st1, Rval (env1, decs)) => if st1.clock = 0 then diff --git a/semantics/semanticPrimitivesScript.sml b/semantics/semanticPrimitivesScript.sml index a49481243a..9346b774b6 100644 --- a/semantics/semanticPrimitivesScript.sml +++ b/semantics/semanticPrimitivesScript.sml @@ -196,14 +196,17 @@ Datatype: | W8array (word8 list) (* An array of values *) | Varray ('a list) + (* Thunk *) + | Thunk bool 'a End Definition store_v_same_type_def: store_v_same_type v1 v2 = case (v1:'a store_v, v2:'a store_v) of - | (Refv _, Refv _) => T - | (W8array _,W8array _) => T - | (Varray _,Varray _) => T + | (Refv _, Refv _ ) => T + | (W8array _, W8array _) => T + | (Varray _, Varray _ ) => T + | (Thunk _ _, Thunk _ _) => T | _ => F End @@ -879,6 +882,17 @@ Termination WF_REL_TAC `measure (\ (_, l). v1_size l)` \\ fs[] End +Definition thunk_op_def: + thunk_op (s: v store_v list, t: 'ffi ffi_state) (AllocThunk b) [v] = + (let (s',n) = store_alloc (Thunk b v) s in + SOME ((s',t), Rval (Loc F n))) ∧ + thunk_op (s, t) (UpdateThunk b) [Loc _ lnum; v] = + (case store_assign lnum (Thunk b v) s of + SOME s' => SOME ((s',t), Rval (Conv NONE [])) + | NONE => NONE) ∧ + thunk_op _ _ _ = NONE +End + Definition do_app_def: do_app (s: v store_v list, t: 'ffi ffi_state) op vs = case (op, vs) of @@ -1254,6 +1268,7 @@ Definition do_app_def: Rval (Conv NONE [nat_to_v gen; nat_to_v id])) | (Env_id, [Conv NONE [gen; id]]) => SOME ((s, t), Rval (Conv NONE [gen; id])) + | (ThunkOp th_op, vs) => thunk_op (s,t) th_op vs | _ => NONE End From a946c1a403f1fb6933b956b3e83a40ea1745000f Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Thu, 5 Dec 2024 11:18:40 +0100 Subject: [PATCH 002/112] Update for thunks in CakeML source --- semantics/proofs/evaluatePropsScript.sml | 48 ++++++++++++++----- semantics/proofs/fpSemPropsScript.sml | 10 ++-- .../proofs/semanticPrimitivesPropsScript.sml | 27 ++++++----- semantics/proofs/typeSoundScript.sml | 12 +++-- semantics/semanticPrimitivesScript.sml | 21 ++++---- translator/ml_translatorScript.sml | 5 +- 6 files changed, 79 insertions(+), 44 deletions(-) diff --git a/semantics/proofs/evaluatePropsScript.sml b/semantics/proofs/evaluatePropsScript.sml index 2fb7c96fc2..eddd0411f6 100644 --- a/semantics/proofs/evaluatePropsScript.sml +++ b/semantics/proofs/evaluatePropsScript.sml @@ -88,8 +88,8 @@ Theorem do_app_call_FFI_rel: do_app (r,ffi) op vs = SOME ((r',ffi'),res) ⇒ call_FFI_rel^* ffi ffi' Proof - srw_tac[][do_app_cases] >> rw[] >> - FULL_CASE_TAC >> + srw_tac[][do_app_cases,thunk_op_def,AllCaseEqs(),store_alloc_def] >> rw[] >> + TRY FULL_CASE_TAC >> fs[option_case_eq] >> rpt (FULL_CASE_TAC \\ fs[]) >> match_mp_tac RTC_SUBSET >> rw[call_FFI_rel_def] >> fs[] >> every_case_tac @@ -283,8 +283,8 @@ Theorem do_app_refs_length: do_app refs_ffi op vs = SOME res ==> LENGTH (FST refs_ffi) <= LENGTH (FST (FST res)) Proof - rw [] \\ Cases_on `refs_ffi` \\ Cases_on `op` \\ fs [do_app_def] - \\ every_case_tac \\ fs [] + rw [] \\ Cases_on `refs_ffi` \\ Cases_on `op` + \\ gvs [do_app_def,thunk_op_def,AllCaseEqs(),store_assign_def] \\ fs [store_assign_def,store_alloc_def] \\ rveq \\ fs [] \\ rveq \\ fs[] QED @@ -418,7 +418,7 @@ val step_tac = @ map ho_match_mp_tac [is_clock_io_mono_bind, is_clock_io_mono_check] @ [CHANGED_TAC (fs [Cong is_clock_io_mono_cong, is_clock_io_mono_return, is_clock_io_mono_err, - do_eval_res_def, dec_inc_clock]), TOP_CASE_TAC])) + do_eval_res_def, dec_inc_clock]), TOP_CASE_TAC])); Theorem is_clock_io_mono_evaluate: (!(s : 'ffi state) env es. is_clock_io_mono (\s. evaluate s env es) s) /\ @@ -449,6 +449,7 @@ Proof is_clock_io_mono_do_app_simple]), CASE_TAC]) \\ ho_match_mp_tac is_clock_io_mono_check \\ gs[] \\ rpt strip_tac \\ res_tac \\ gs[dec_inc_clock]) + >- cheat (* Force *) >- (assume_tac (SIMP_RULE std_ss [] is_clock_io_mono_do_app_simple) \\ fs[]) >- (assume_tac (SIMP_RULE std_ss [] is_clock_io_mono_do_app_icing) \\ gs[]) \\ assume_tac (SIMP_RULE std_ss [] is_clock_io_mono_do_app_real) \\ fs[]) @@ -892,7 +893,21 @@ Proof \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac \\ rpt gen_tac \\ strip_tac \\ fs [evaluate_case_eqs, dec_clock_def, do_eval_res_def, shift_fp_opts_def] - \\ TRY (Cases_on ‘getOpClass op’) + >~ [‘op:op’] >- + (Cases_on ‘getOpClass op = Force’ >- cheat + \\ Cases_on ‘getOpClass op’ \\ fs [] + \\ fs [evaluate_case_eqs, dec_clock_def, do_eval_res_def] + \\ rveq \\ fs [] + \\ fs [Q.ISPEC `(_, _)` EQ_SYM_EQ] + \\ rveq \\ fs [] + \\ imp_res_tac evaluate_next_type_stamp_mono + \\ imp_res_tac evaluate_next_exn_stamp_mono + \\ rw [] + \\ fs [build_tdefs_def] + \\ qpat_x_assum `fix_clock _ _ = _` mp_tac + \\ rpt (TOP_CASE_TAC \\ gs[fix_clock_def]) + \\ rpt strip_tac \\ rveq + \\ gs[fix_clock_def]) \\ fs [evaluate_case_eqs, dec_clock_def, do_eval_res_def] \\ rveq \\ fs [] \\ fs [Q.ISPEC `(_, _)` EQ_SYM_EQ] @@ -924,8 +939,9 @@ Theorem do_app_ffi_unchanged: !ffi2. do_app (refs, ffi2) op vs = SOME ((refs',ffi2), r) Proof disch_then (strip_assume_tac o REWRITE_RULE [do_app_cases]) - \\ rw [do_app_def] \\ rveq \\ fs [] - \\ every_case_tac \\ rveq \\ fs [] \\ rveq \\ fs [] + \\ gvs [do_app_def,oneline thunk_op_def,AllCaseEqs()] + \\ CCONTR_TAC \\ gvs [] + \\ rpt (pairarg_tac \\ gvs []) \\ fs [call_FFI_return_unchanged, Q.SPECL [`x`, `ExtCall ""`] ffiTheory.call_FFI_def] \\ rveq \\ fs [] @@ -1047,6 +1063,7 @@ Proof `evaluate (dec_clock s2) _ _ = (s3, _)`] \\ fs[dec_clock_def] \\ by_eq) + >- cheat (* Force *) >- ( ntac 2 (TOP_CASE_TAC \\ fs[]) >- (trivial) \\ ntac 2 (TOP_CASE_TAC \\ fs[]) @@ -1187,6 +1204,7 @@ Proof `evaluate (dec_clock s2) _ _ = (s3, _)`] \\ fs[dec_clock_def] \\ by_eq) + >- cheat (* Force *) >- ( ntac 2 (TOP_CASE_TAC \\ fs[]) >- (trivial) \\ ntac 2 (TOP_CASE_TAC \\ fs[]) @@ -1345,6 +1363,7 @@ Proof `evaluate (dec_clock s2) _ _ = (s3, _)`] \\ fs[dec_clock_def] \\ by_eq) + >- cheat (* Force *) >- ( ntac 2 (TOP_CASE_TAC \\ fs[]) >- (trivial) \\ ntac 2 (TOP_CASE_TAC \\ fs[]) @@ -1479,6 +1498,8 @@ Proof \\ TRY (rename1 ‘_ = Icing’ \\ qpat_x_assum ‘∀ outcome. _ ≠ Rerr (Rabort _)’ mp_tac \\ ntac 4 TOP_CASE_TAC \\ gs[shift_fp_opts_def]) + \\ TRY (rename1 ‘_ = Force’ + \\ cheat) \\ TRY (imp_res_tac do_app_io_events_mono \\ imp_res_tac io_events_mono_trans \\ CHANGED_TAC (rpt @@ -1675,6 +1696,7 @@ Proof \\ TRY (rename [`Case ([App _ _])`] ORELSE cheat) *) \\ TRY (rename [`Case ([App _ _])`] + \\ Cases_on ‘getOpClass op = Force’ >- cheat \\ Cases_on ‘getOpClass op’ \\ gs[] \\ rpt (MAP_FIRST (dxrule_then (strip_assume_tac o SIMP_RULE bool_ss [])) [hd (RES_CANON pair_case_eq), hd (RES_CANON result_case_eq), hd (RES_CANON bool_case_eq)] @@ -1782,8 +1804,8 @@ Theorem do_app_ffi_mono: ?l. ffi'.io_events = ffi.io_events ++ l Proof rw[] - \\ fs[semanticPrimitivesPropsTheory.do_app_cases] - \\ rw[] \\ fs[] + \\ gvs [semanticPrimitivesPropsTheory.do_app_cases,oneline thunk_op_def, + AllCaseEqs(),store_alloc_def] \\ fs[ffiTheory.call_FFI_def] \\ rpt(PURE_FULL_CASE_TAC >> fs[] >> rveq) \\ rveq \\ fs[ffiTheory.ffi_state_component_equality,DROP_LENGTH_NIL] @@ -1798,7 +1820,8 @@ Theorem do_app_SOME_ffi_same_oracle_state: Proof simp [Once semanticPrimitivesPropsTheory.do_app_cases] \\ rw [] - \\ fs [do_app_def] + \\ gvs [do_app_def,oneline thunk_op_def,AllCaseEqs(),store_alloc_def] + >- (CCONTR_TAC \\ gvs []) \\ simp [DROP_LENGTH_NIL] \\ fs[ffiTheory.call_FFI_def] \\ rpt(PURE_FULL_CASE_TAC >> fs[] >> rveq) @@ -1827,10 +1850,9 @@ Theorem evaluate_history_irrelevance: Proof ho_match_mp_tac full_evaluate_ind \\ rw[full_evaluate_def] - \\ TRY (Cases_on ‘getOpClass op’ \\ gs[]) \\ fs [do_eval_res_def,error_result_case_eq,option_case_eq, exp_or_val_case_eq,list_case_eq,match_result_case_eq, - pair_case_eq,result_case_eq,bool_case_eq] + pair_case_eq,result_case_eq,bool_case_eq,AllCaseEqs()] \\ rveq \\ fs [] \\ simp [rich_listTheory.DROP_LENGTH_NIL_rwt] \\ fs [Q.ISPEC `(a, b)` EQ_SYM_EQ, dec_clock_def] diff --git a/semantics/proofs/fpSemPropsScript.sml b/semantics/proofs/fpSemPropsScript.sml index 5fcac1ddb4..65980754aa 100644 --- a/semantics/proofs/fpSemPropsScript.sml +++ b/semantics/proofs/fpSemPropsScript.sml @@ -118,7 +118,7 @@ Theorem fpOp_determ: Proof rpt strip_tac \\ Cases_on `op` \\ fs[astTheory.getOpClass_def] \\ rpt (qpat_x_assum `do_app _ _ _ = _` mp_tac) - \\ fs[do_app_def] + \\ fs[do_app_def,thunk_op_def] \\ rpt (TOP_CASE_TAC \\ fs[]) QED @@ -130,11 +130,10 @@ Theorem realOp_determ: Proof rpt strip_tac \\ Cases_on `op` \\ fs[astTheory.getOpClass_def] \\ rpt (qpat_x_assum `do_app _ _ _ = _` mp_tac) - \\ fs[do_app_def] + \\ fs[do_app_def,thunk_op_def] \\ rpt (TOP_CASE_TAC \\ fs[]) QED - Theorem evaluate_fp_stable: ! (s1 s2) env exps r. s1.fp_state.choices = s2.fp_state.choices /\ @@ -258,7 +257,7 @@ Theorem evaluate_fp_opt_add_bind: (∀ (st1:'a state) env v pl err_v. ^eval_match_goal st1 env v pl err_v) ∧ (∀ (st1:'a state) env decls. - ^eval_decs_goal st1 env decls) + ^eval_decs_goal st1 env decls) Proof match_mp_tac indThm \\ rpt strip_tac \\ fs[evaluate_def, evaluate_decs_def] @@ -318,6 +317,7 @@ Proof \\ ntac 2 (TOP_CASE_TAC \\ fs[]) >- solve_simple \\ solve_complex) + >- cheat >- ( TOP_CASE_TAC \\ fs[] >- solve_simple @@ -673,6 +673,8 @@ Proof \\ ntac 2 (TOP_CASE_TAC \\ fs[]) >- solve_simple \\ strip_tac \\ fs[dec_clock_def] \\ solve_complex) + (* Force *) + >- cheat (* Simple *) >- ( TOP_CASE_TAC \\ fs[] >- solve_simple diff --git a/semantics/proofs/semanticPrimitivesPropsScript.sml b/semantics/proofs/semanticPrimitivesPropsScript.sml index 4038c24b70..5826b0cbb4 100644 --- a/semantics/proofs/semanticPrimitivesPropsScript.sml +++ b/semantics/proofs/semanticPrimitivesPropsScript.sml @@ -275,7 +275,7 @@ Theorem do_app_NONE_ffi: do_app (refs,ffi) op args = NONE ⇒ do_app (refs,ffi') op args = NONE Proof - Cases_on `op` \\ fs [do_app_def] + Cases_on `op` \\ fs [do_app_def,thunk_op_def] \\ gvs [AllCaseEqs()] \\ rpt strip_tac \\ gvs [] \\ rpt (pairarg_tac \\ gvs[]) \\ every_case_tac \\ fs[] @@ -288,7 +288,7 @@ Theorem do_app_SOME_ffi_same: do_app (refs,ffi') op args = SOME ((refs',ffi'),r) Proof rw[] - \\ gvs [do_app_def,AllCaseEqs()] + \\ gvs [do_app_def,AllCaseEqs(),thunk_op_def] \\ rpt (pairarg_tac \\ gvs []) \\ fs[ffiTheory.call_FFI_def] \\ gvs [do_app_def,AllCaseEqs()] @@ -302,7 +302,7 @@ Theorem do_app_ffi_unchanged: do_app (st, ffi) op vs = SOME ((st', ffi'), res) ⇒ ffi = ffi' Proof - rpt gen_tac >> simp[do_app_def] >> + rpt gen_tac >> simp[do_app_def,thunk_op_def] >> every_case_tac >> gvs[store_alloc_def] QED @@ -329,7 +329,8 @@ Theorem do_app_ffi_changed: [IO_event (ExtCall s) (MAP (λc. n2w $ ORD c) (EXPLODE conf)) (ZIP (ws,ws'))] Proof - simp[do_app_def] >> every_case_tac >> gvs[store_alloc_def, store_assign_def] >> + simp[do_app_def,thunk_op_def] >> + every_case_tac >> gvs[store_alloc_def, store_assign_def] >> strip_tac >> gvs[call_FFI_def] >> every_case_tac >> gvs[combinTheory.o_DEF, IMPLODE_EXPLODE_I] QED @@ -340,16 +341,15 @@ Theorem do_app_not_timeout: a ≠ Rtimeout_error Proof Cases_on `s` >> - srw_tac[][do_app_cases] >> - every_case_tac >> - srw_tac[][] + srw_tac[][do_app_cases,thunk_op_def,AllCaseEqs(),store_alloc_def] >> + gvs [] QED Theorem do_app_type_error: do_app s op es = SOME (x,Rerr (Rabort a)) ⇒ x = s Proof PairCases_on `s` >> - srw_tac[][do_app_def] >> + srw_tac[][do_app_def,thunk_op_def] >> every_case_tac >> full_simp_tac(srw_ss())[LET_THM,UNCURRY] >> every_case_tac >> full_simp_tac(srw_ss())[] QED @@ -517,7 +517,8 @@ val _ = export_rewrites["every_result_def"] Definition map_sv_def: map_sv f (Refv v) = Refv (f v) ∧ map_sv _ (W8array w) = (W8array w) ∧ - map_sv f (Varray vs) = (Varray (MAP f vs)) + map_sv f (Varray vs) = (Varray (MAP f vs)) ∧ + map_sv f (Thunk b v) = (Thunk b (f v)) End val _ = export_rewrites["map_sv_def"] @@ -533,6 +534,7 @@ val _ = export_rewrites["dest_Refv_def","is_Refv_def"] Definition sv_every_def: sv_every P (Refv v) = P v ∧ sv_every P (Varray vs) = EVERY P vs ∧ + sv_every P (Thunk b v) = P v ∧ sv_every P _ = T End val _ = export_rewrites["sv_every_def"] @@ -541,6 +543,7 @@ Definition sv_rel_def: sv_rel R (Refv v1) (Refv v2) = R v1 v2 ∧ sv_rel R (W8array w1) (W8array w2) = (w1 = w2) ∧ sv_rel R (Varray vs1) (Varray vs2) = LIST_REL R vs1 vs2 ∧ + sv_rel R (Thunk b1 v1) (Thunk b2 v2) = (b1 = b2 ∧ R v1 v2) ∧ sv_rel R _ _ = F End val _ = export_rewrites["sv_rel_def"] @@ -565,9 +568,10 @@ Theorem sv_rel_cases: sv_rel R x y ⇔ (∃v1 v2. x = Refv v1 ∧ y = Refv v2 ∧ R v1 v2) ∨ (∃w. x = W8array w ∧ y = W8array w) ∨ + (∃b v1 v2. x = Thunk b v1 ∧ y = Thunk b v2 ∧ R v1 v2) ∨ (?vs1 vs2. x = Varray vs1 ∧ y = Varray vs2 ∧ LIST_REL R vs1 vs2) Proof - Cases >> Cases >> simp[sv_rel_def,EQ_IMP_THM] + Cases >> Cases >> simp[sv_rel_def,EQ_IMP_THM] >> metis_tac [] QED Theorem sv_rel_O: @@ -586,7 +590,8 @@ QED Definition store_v_vs_def: store_v_vs (Refv v) = [v] ∧ store_v_vs (Varray vs) = vs ∧ - store_v_vs (W8array _) = [] + store_v_vs (W8array _) = [] ∧ + store_v_vs (Thunk _ v) = [v] End val _ = export_rewrites["store_v_vs_def"] diff --git a/semantics/proofs/typeSoundScript.sml b/semantics/proofs/typeSoundScript.sml index 7183ac043a..a1ac9c3dfc 100644 --- a/semantics/proofs/typeSoundScript.sml +++ b/semantics/proofs/typeSoundScript.sml @@ -1406,8 +1406,8 @@ Theorem fpOp_no_err: Proof rpt strip_tac \\ qpat_x_assum `do_app _ _ _ = _` mp_tac - \\ Cases_on `isFpBool op` \\ Cases_on `op` \\ fs[getOpClass_def, isFpBool_def, do_app_def] - \\ rpt (TOP_CASE_TAC \\ fs[]) + \\ Cases_on `isFpBool op` \\ Cases_on `op` + \\ fs[getOpClass_def, isFpBool_def, do_app_def, oneline thunk_op_def, AllCaseEqs()] \\ rpt strip_tac \\ rveq \\ fs[] QED @@ -1758,7 +1758,7 @@ Proof >> rw [] >> metis_tac [store_type_extension_trans]) >> `getOpClass op ≠ FunApp` - by (Cases_on `op` >> fs[getOpClass_def]) + by (Cases_on `op` >> fs[getOpClass_def,AllCaseEqs()]) >> Cases_on `getOpClass op = Icing` >> fs[] >- ( (* FP ops *) Cases_on `s1.fp_state.canOpt = FPScope Opt` @@ -1801,6 +1801,10 @@ Proof >- ( Cases_on `op` >> fs[getOpClass_def] >> Cases_on `ts` >> fs[type_op_def]) + >> Cases_on `getOpClass op = Force` + >- ( + Cases_on `op` >> gvs[getOpClass_def,AllCaseEqs()] + >> Cases_on `ts` >> fs[type_op_def]) >> Cases_on ‘getOpClass op = EvalOp’ >- ( Cases_on ‘op’ >> gs[getOpClass_def] @@ -1810,7 +1814,7 @@ Proof >> drule op_type_sound >> rpt (disch_then drule) >> disch_then (qspec_then `s1.ffi` mp_tac) - >> `getOpClass op = Simple` by (Cases_on `op` >> fs[getOpClass_def]) + >> `getOpClass op = Simple` by (Cases_on `op` >> fs[getOpClass_def,AllCaseEqs()]) >> rw [] >> rename1 `do_app _ _ _ = SOME ((store1, ffi1), r1)` >> Cases_on `r1` diff --git a/semantics/semanticPrimitivesScript.sml b/semantics/semanticPrimitivesScript.sml index 9346b774b6..6efac61f1c 100644 --- a/semantics/semanticPrimitivesScript.sml +++ b/semantics/semanticPrimitivesScript.sml @@ -426,8 +426,7 @@ Definition pmatch_def: (case store_lookup lnum s of NONE => Match_type_error | SOME (Refv v) => pmatch envC s p v env - | SOME (W8array v6) => Match_type_error - | SOME (Varray v7) => Match_type_error) ∧ + | SOME _ => Match_type_error) ∧ pmatch envC s (Pas p i) v env = pmatch envC s p v ((i,v)::env) ∧ pmatch envC s (Ptannot p t) v env = pmatch envC s p v env ∧ pmatch envC s _ _ env = Match_type_error ∧ @@ -883,14 +882,16 @@ Termination End Definition thunk_op_def: - thunk_op (s: v store_v list, t: 'ffi ffi_state) (AllocThunk b) [v] = - (let (s',n) = store_alloc (Thunk b v) s in - SOME ((s',t), Rval (Loc F n))) ∧ - thunk_op (s, t) (UpdateThunk b) [Loc _ lnum; v] = - (case store_assign lnum (Thunk b v) s of - SOME s' => SOME ((s',t), Rval (Conv NONE [])) - | NONE => NONE) ∧ - thunk_op _ _ _ = NONE + thunk_op (s: v store_v list, t: 'ffi ffi_state) th_op vs = + case (th_op,vs) of + | (AllocThunk b, [v]) => + (let (s',n) = store_alloc (Thunk b v) s in + SOME ((s',t), Rval (Loc F n))) + | (UpdateThunk b, [Loc _ lnum; v]) => + (case store_assign lnum (Thunk b v) s of + | SOME s' => SOME ((s',t), Rval (Conv NONE [])) + | NONE => NONE) + | _ => NONE End Definition do_app_def: diff --git a/translator/ml_translatorScript.sml b/translator/ml_translatorScript.sml index 7910426b01..17dce8a1fb 100644 --- a/translator/ml_translatorScript.sml +++ b/translator/ml_translatorScript.sml @@ -2674,6 +2674,7 @@ Definition no_change_refs_def: | Aupdate => F | Aupdate_unsafe => F | FFI _ => F + | ThunkOp _ => F | _ => T) ∧ EVERY no_change_refs es) /\ no_change_refs _ = F Termination @@ -2695,8 +2696,8 @@ Proof \\ fs [no_change_refs_def] \\ rw [] \\ gvs [evaluate_def,AllCaseEqs(),semanticPrimitivesTheory.do_if_def] \\ fs [SF ETA_ss] - \\ gvs [] - \\ fs [do_app_cases] \\ rveq \\ fs [] + \\ gvs [do_app_def] + \\ gvs [AllCaseEqs(),thunk_op_def,store_alloc_def] QED Theorem eval_rel_no_change_refs: From 9f672f54b81ca754058bb5666b6dd7ce5f03d7c1 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Thu, 5 Dec 2024 13:35:07 +0100 Subject: [PATCH 003/112] Updates for thunks --- characteristic/cfAppScript.sml | 3 ++- translator/ml_optimiseScript.sml | 12 +++++------- 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/characteristic/cfAppScript.sml b/characteristic/cfAppScript.sml index c7cd3a89a8..7eb4064bc6 100644 --- a/characteristic/cfAppScript.sml +++ b/characteristic/cfAppScript.sml @@ -616,7 +616,8 @@ Theorem do_app_io_events_ExtCall: ?s bs bs'. io_ev = IO_event (ExtCall s) bs bs' Proof strip_tac >> - gvs[DefnBase.one_line_ify NONE do_app_def, + gvs[oneline do_app_def, + oneline thunk_op_def, store_alloc_def, AllCaseEqs(),ffiTheory.call_FFI_def] >> pairarg_tac >> fs[] QED diff --git a/translator/ml_optimiseScript.sml b/translator/ml_optimiseScript.sml index 95c87fcd92..e2996376b3 100644 --- a/translator/ml_optimiseScript.sml +++ b/translator/ml_optimiseScript.sml @@ -179,8 +179,7 @@ Proof \\ first_x_assum drule \\ simp [] \\ strip_tac \\ asm_exists_tac \\ fs []) THEN1 (* App Eval *) - ( - fs [evaluateTheory.do_eval_res_def, Q.ISPEC `(_, _)` EQ_SYM_EQ] + (fs [evaluateTheory.do_eval_res_def, Q.ISPEC `(_, _)` EQ_SYM_EQ] \\ fs [list_case_eq,option_case_eq,bool_case_eq,pair_case_eq,result_case_eq] \\ rveq \\ fs [PULL_EXISTS] \\ `? st_x ck_x. st' = (st_x with clock := ck_x) /\ st_x.clock = s.clock` @@ -193,12 +192,9 @@ Proof \\ asm_exists_tac \\ simp [] \\ dxrule_then (qspec_then `ck2` mp_tac) evaluate_decs_add_to_clock - \\ rw [evaluateTheory.dec_clock_def] - ) + \\ rw [evaluateTheory.dec_clock_def]) THEN1 - ( - fs [error_result_case_eq] - ) + (fs [error_result_case_eq]) THEN1 (* App Opapp *) (rename1 `_ = (st1,Rval vs)` \\ `evaluate (s with clock := ck1) env (REVERSE xs) = @@ -215,6 +211,8 @@ Proof \\ disch_then (qspec_then `st1.clock+1` assume_tac) \\ asm_exists_tac \\ fs [] \\ fs [evaluateTheory.dec_clock_def,state_component_equality]) + THEN1 (* App Force *) + cheat THEN1 (* App Simple *) (rename1 `_ = (st1,Rval vs)` \\ `evaluate (s with clock := ck1) env (REVERSE xs) = From f74fa8b5891f000ad74e23d81d7e5ef942adfb79 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Sun, 8 Dec 2024 12:27:44 +0100 Subject: [PATCH 004/112] Update inferencer for Thunks --- compiler/inference/inferScript.sml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/compiler/inference/inferScript.sml b/compiler/inference/inferScript.sml index 43acf9b69a..481d55ad52 100644 --- a/compiler/inference/inferScript.sml +++ b/compiler/inference/inferScript.sml @@ -798,6 +798,7 @@ constrain_op l op ts s = | (AallocFixed, _) => failwith l (implode "Unsafe ops do not have a type") s(* not actually unsafe *) | (Eval, _) => failwith l (implode "Unsafe ops do not have a type") s | (Env_id, _) => failwith l (implode "Unsafe ops do not have a type") s + | (ThunkOp _, _) => failwith l (implode "Thunk ops do not have a type") s | _ => failwith l (op_n_args_msg op (LENGTH ts)) s End @@ -821,12 +822,13 @@ Theorem constrain_op_error_msg_sanity: LENGTH args = SND (op_to_string op) ∧ constrain_op l op args s = (Failure (l',msg), s') ⇒ - IS_PREFIX (explode msg) "Type mismatch" \/ - IS_PREFIX (explode msg) "Unsafe" \/ + IS_PREFIX (explode msg) "Type mismatch" ∨ + IS_PREFIX (explode msg) "Unsafe" ∨ + IS_PREFIX (explode msg) "Thunk" ∨ IS_PREFIX (explode msg) "Real" Proof rpt strip_tac >> - qmatch_abbrev_tac `IS_PREFIX _ m1 \/ IS_PREFIX _ m2 \/ IS_PREFIX _ m3` >> + qmatch_abbrev_tac `IS_PREFIX _ m1 \/ IS_PREFIX _ m2 \/ IS_PREFIX _ m3 \/ IS_PREFIX _ m4` >> cases_on `op` >> fs [op_to_string_def, constrain_op_dtcase_def, op_simple_constraints_def] >> gvs [LENGTH_EQ_NUM_compute] >> From 1a0325b0399550578d64d7e6b3d11d8a21ae341d Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Sun, 8 Dec 2024 15:18:28 +0100 Subject: [PATCH 005/112] Fix a mistake in Thunk semantics --- semantics/semanticPrimitivesScript.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/semantics/semanticPrimitivesScript.sml b/semantics/semanticPrimitivesScript.sml index 6efac61f1c..c673f57f6c 100644 --- a/semantics/semanticPrimitivesScript.sml +++ b/semantics/semanticPrimitivesScript.sml @@ -206,7 +206,7 @@ Definition store_v_same_type_def: | (Refv _, Refv _ ) => T | (W8array _, W8array _) => T | (Varray _, Varray _ ) => T - | (Thunk _ _, Thunk _ _) => T + | (Thunk T _, Thunk _ _) => T (* the thunk being updated must have T set *) | _ => F End From e7786bc71848d01767daef78b606e703890a6b16 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Tue, 10 Dec 2024 21:35:05 +0100 Subject: [PATCH 006/112] Some progress on thunks --- candle/prover/candle_basis_evaluateScript.sml | 3 +- candle/prover/candle_kernel_funsScript.sml | 3 +- .../prover/candle_prover_evaluateScript.sml | 6 ++- candle/prover/permsScript.sml | 6 ++- compiler/backend/flatLangScript.sml | 2 + compiler/backend/flat_to_closScript.sml | 11 ++++ compiler/backend/presLangScript.sml | 10 ++++ .../backend/proofs/flat_elimProofScript.sml | 6 ++- .../proofs/flat_patternProofScript.sml | 3 +- .../proofs/flat_to_closProofScript.sml | 16 ++++-- .../backend/proofs/source_evalProofScript.sml | 18 ++++--- .../proofs/source_to_flatProofScript.sml | 6 ++- .../backend/semantics/flatPropsScript.sml | 41 ++++++++------ compiler/backend/semantics/flatSemScript.sml | 54 ++++++++++++++++--- compiler/backend/source_to_flatScript.sml | 1 + compiler/inference/inferScript.sml | 5 +- compiler/parsing/fromSexpScript.sml | 33 +++++++++++- compiler/repl/evaluate_initScript.sml | 6 ++- compiler/repl/evaluate_skipScript.sml | 12 +++-- .../alt_semantics/proofs/bigClockScript.sml | 17 +++--- .../proofs/bigSmallEquivScript.sml | 16 +++--- .../proofs/funBigStepEquivScript.sml | 6 ++- .../alt_semantics/proofs/interpScript.sml | 8 ++- .../proofs/itree_semanticsEquivScript.sml | 12 +++-- .../proofs/itree_semanticsPropsScript.sml | 3 +- .../proofs/smallStepPropsScript.sml | 6 ++- 26 files changed, 236 insertions(+), 74 deletions(-) diff --git a/candle/prover/candle_basis_evaluateScript.sml b/candle/prover/candle_basis_evaluateScript.sml index 1c9675e5ad..6c1541a659 100644 --- a/candle/prover/candle_basis_evaluateScript.sml +++ b/candle/prover/candle_basis_evaluateScript.sml @@ -217,6 +217,7 @@ QED Theorem evaluate_basis_v_ok_App: ^(get_goal "App") Proof + cheat (* rw [evaluate_def] \\ Cases_on ‘getOpClass op’ \\ gvs [CaseEqs ["bool", "option", "prod", "semanticPrimitives$result"], SF SFY_ss] @@ -238,7 +239,7 @@ Proof \\ first_x_assum irule \\ gs [] \\ gs [post_state_ok_def])) >- (Cases_on ‘op’ \\ gs[]) - >- (Cases_on ‘op’ \\ gs[]) + >- (Cases_on ‘op’ \\ gs[]) *) QED Theorem evaluate_basis_v_ok_FpOptimise: diff --git a/candle/prover/candle_kernel_funsScript.sml b/candle/prover/candle_kernel_funsScript.sml index b0b58a7edf..3bc81f6183 100644 --- a/candle/prover/candle_kernel_funsScript.sml +++ b/candle/prover/candle_kernel_funsScript.sml @@ -451,8 +451,9 @@ Theorem ref_ok_APPEND: !x s. STATE (x ++ c) s /\ (!th. THM c th ==> THM (x ++ c) th) ==> ref_ok (x ++ c) v Proof + cheat (* gen_tac \\ Cases \\ rw[ref_ok_def] - \\ fs[EVERY_MEM] \\ metis_tac[v_ok_APPEND] + \\ fs[EVERY_MEM] \\ metis_tac[v_ok_APPEND] *) QED Theorem inferred_ok: diff --git a/candle/prover/candle_prover_evaluateScript.sml b/candle/prover/candle_prover_evaluateScript.sml index d3690a0b27..671784eb42 100644 --- a/candle/prover/candle_prover_evaluateScript.sml +++ b/candle/prover/candle_prover_evaluateScript.sml @@ -285,6 +285,7 @@ Theorem do_app_ok: | Rerr (Rraise v) => v_ok ctxt v | _ => T Proof + cheat (* strip_tac \\ qpat_x_assum ‘do_app _ _ _ = _’ mp_tac \\ Cases_on ‘op = Env_id’ \\ gs [] @@ -653,12 +654,13 @@ Proof rw[do_app_cases] \\ gs [SF SFY_ss] \\ first_assum (irule_at Any) \\ simp [v_ok_def]) - \\ Cases_on ‘op’ \\ gs [] + \\ Cases_on ‘op’ \\ gs [] *) QED Theorem evaluate_v_ok_Op: op ≠ Opapp ∧ op ≠ Eval ⇒ ^(get_goal "ast$App") Proof + cheat (* rw [evaluate_def] \\ Cases_on ‘getOpClass op’ \\ gs[] >~ [‘EvalOp’] >- (Cases_on ‘op’ \\ gs[]) >~ [‘FunApp’] >- (Cases_on ‘op’ \\ gs[]) @@ -695,7 +697,7 @@ Proof \\ disch_then drule_all \\ simp [] \\ strip_tac \\ gs [] \\ rpt CASE_TAC \\ gs [] - \\ first_assum (irule_at Any) \\ gs []) + \\ first_assum (irule_at Any) \\ gs []) *) QED Theorem evaluate_v_ok_Opapp: diff --git a/candle/prover/permsScript.sml b/candle/prover/permsScript.sml index c15ea1c5d4..8339ef3ceb 100644 --- a/candle/prover/permsScript.sml +++ b/candle/prover/permsScript.sml @@ -320,6 +320,7 @@ Theorem do_app_perms: | Rerr (Rraise v) => perms_ok ps v | Rerr (Rabort err) => T Proof + cheat (* strip_tac \\ qpat_x_assum ‘do_app _ _ _ = _’ mp_tac \\ Cases_on ‘op = Env_id’ \\ gs [] @@ -581,7 +582,7 @@ Proof >- ( rw [do_app_cases] \\ gs[] \\ rw [perms_ok_def]) - \\ Cases_on ‘op’ \\ gs [] + \\ Cases_on ‘op’ \\ gs [] *) QED Theorem perms_ok_do_opapp: @@ -691,6 +692,7 @@ Theorem evaluate_perms_ok: | Rval env1 => perms_ok_env ps UNIV env1 | _ => T) Proof + cheat (* ho_match_mp_tac full_evaluate_ind \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac >~ [‘[]’] >- ( @@ -978,7 +980,7 @@ Proof gs [perms_ok_env_def, extend_dec_env_def, nsLookup_nsAppend_some] \\ rw [] \\ gs [SF SFY_ss]) \\ rw [] - \\ first_x_assum (drule_then assume_tac) \\ gs []) + \\ first_x_assum (drule_then assume_tac) \\ gs []) *) QED Theorem evaluate_perms_ok_exp = diff --git a/compiler/backend/flatLangScript.sml b/compiler/backend/flatLangScript.sml index 2e7e4e5b72..0c5ce995be 100644 --- a/compiler/backend/flatLangScript.sml +++ b/compiler/backend/flatLangScript.sml @@ -102,6 +102,8 @@ Datatype: | El num (* No-op step for a single value *) | Id + (* Thunk *) + | ThunkOp ast$thunk_op End Type ctor_id = ``:num`` diff --git a/compiler/backend/flat_to_closScript.sml b/compiler/backend/flat_to_closScript.sml index 846778aec1..839411c456 100644 --- a/compiler/backend/flat_to_closScript.sml +++ b/compiler/backend/flat_to_closScript.sml @@ -189,6 +189,17 @@ Definition compile_op_def: | Shift x1 x2 x3 => Op t (WordShift x1 x2 x3) xs | Opw x1 x2 => Op t (WordOp x1 x2) xs | Eval => Op t Install xs (* if need to flip: Let t xs (Op t Install [Var t 1; Var t 0]) *) + | ThunkOp t => + (dtcase t of + | AllocThunk b => + Let None xs (Op None Ref [Op None (Cons (if b then 1 else 0)) []; Var None 0]) + | UpdateThunk b => + Let None xs (Let None + [Op None Update [Var None 0; Op None (Const 0) []; Op None (Cons (if b then 1 else 0)) []]; + Op None Update [Var None 0; Op None (Const 1) []; Var None 1]] + (Var None 0)) + | ForceThunk => + Let None xs (Var None 0)) | _ => Let None xs (Var None 0) End diff --git a/compiler/backend/presLangScript.sml b/compiler/backend/presLangScript.sml index bb727935c4..59ab9b9325 100644 --- a/compiler/backend/presLangScript.sml +++ b/compiler/backend/presLangScript.sml @@ -256,6 +256,11 @@ Definition op_to_display_def: | FFI v35 => empty_item (strlit "FFI v35") | Eval => empty_item (strlit "Eval") | Env_id => empty_item (strlit "Eval") + | ThunkOp t => + (case t of + | AllocThunk b => Item NONE (strlit "AllocThunk") [bool_to_display b] + | UpdateThunk b => Item NONE (strlit "UpdateThunk") [bool_to_display b] + | ForceThunk => empty_item (strlit "ForceThunk")) End Definition lop_to_display_def: @@ -452,6 +457,11 @@ Definition flat_op_to_display_def: | ConfigGC => empty_item (strlit "ConfigGC") | FFI s => Item NONE (strlit "FFI") [string_imp s] | Eval => empty_item (strlit "Eval") + | ThunkOp t => + (case t of + | AllocThunk b => Item NONE (strlit "AllocThunk") [bool_to_display b] + | UpdateThunk b => Item NONE (strlit "UpdateThunk") [bool_to_display b] + | ForceThunk => empty_item (strlit "ForceThunk")) | GlobalVarAlloc n => item_with_num (strlit "GlobalVarAlloc") n | GlobalVarInit n => item_with_num (strlit "GlobalVarInit") n | GlobalVarLookup n => item_with_num (strlit "GlobalVarLookup") n diff --git a/compiler/backend/proofs/flat_elimProofScript.sml b/compiler/backend/proofs/flat_elimProofScript.sml index fdf268886f..143945a06e 100644 --- a/compiler/backend/proofs/flat_elimProofScript.sml +++ b/compiler/backend/proofs/flat_elimProofScript.sml @@ -509,6 +509,7 @@ Theorem do_app_SOME_flat_state_rel: domain reachable ∧ EVERY ($~ ∘ v_has_Eval) (result_vs (evaluate$list_result result)) Proof + cheat (* rw [] \\ qpat_assum `flat_state_rel _ _ _` (mp_tac o REWRITE_RULE [flat_state_rel_def]) \\ rw [] @@ -628,7 +629,7 @@ Proof \\ fs [flat_state_rel_def, globals_rel_def, IS_SOME_EXISTS] \\ rfs [] \\ metis_tac [] - ) + ) *) QED @@ -745,6 +746,7 @@ Theorem evaluate_keep_flat_state_rel_eq_lemma: domain (find_sem_prim_res_globals result) ⊆ domain reachable ∧ EVERY (($~) ∘ v_has_Eval) (result_vs result)) Proof + cheat (* ho_match_mp_tac evaluate_exp_ind >> rpt CONJ_TAC >> rpt GEN_TAC >> TRY strip_tac >> TRY (simp [] >> NO_TAC) @@ -1061,7 +1063,7 @@ Proof fs [ELIM_UNCURRY, o_DEF, v_has_Eval_def, EVERY_MAP] >> simp [find_v_globals_MAP_Recclosure] >> rw [o_DEF] - ) + ) *) QED (******** EVALUATE SPECIALISATION ********) diff --git a/compiler/backend/proofs/flat_patternProofScript.sml b/compiler/backend/proofs/flat_patternProofScript.sml index abcbf384e5..78fbdde673 100644 --- a/compiler/backend/proofs/flat_patternProofScript.sml +++ b/compiler/backend/proofs/flat_patternProofScript.sml @@ -1595,6 +1595,7 @@ Theorem compile_exps_evaluate: state_rel s_cfg t1 t2 ) Proof + cheat (* ho_match_mp_tac evaluate_ind2 \\ simp [evaluate_decs_sing] \\ simp [evaluate_def, compile_exp_def, result_vs_def] @@ -1903,7 +1904,7 @@ Proof \\ rveq \\ fs [] \\ rveq \\ fs [] ) \\ fs [] - ) + ) *) QED Theorem compile_decs_eval_sim: diff --git a/compiler/backend/proofs/flat_to_closProofScript.sml b/compiler/backend/proofs/flat_to_closProofScript.sml index 2abc733564..ed176cbd19 100644 --- a/compiler/backend/proofs/flat_to_closProofScript.sml +++ b/compiler/backend/proofs/flat_to_closProofScript.sml @@ -81,6 +81,7 @@ Definition store_rel_def: !i. if LENGTH refs <= i then FLOOKUP t_refs i = NONE else case EL i refs of | Refv v => (?x. FLOOKUP t_refs i = SOME (ValueArray [x]) /\ v_rel v x) + | Thunk b v => (?x. FLOOKUP t_refs i = SOME (ValueArray [Block (if b then 1 else 0) []; x]) /\ v_rel v x) | Varray vs => (?xs. FLOOKUP t_refs i = SOME (ValueArray xs) /\ LIST_REL v_rel vs xs) | W8array bs => FLOOKUP t_refs i = SOME (ByteArray bs) @@ -567,7 +568,9 @@ Proof QED Theorem compile_op_evaluates_args: - evaluate (xs,db,t) = (Rerr err,t1) /\ op <> Opapp /\ op <> Eval ==> + evaluate (xs,db,t) = (Rerr err,t1) /\ + op <> Opapp /\ op <> Eval /\ op <> ThunkOp ForceThunk + ==> evaluate ([compile_op tra op xs],db,t) = (Rerr err,t1) Proof Cases_on `op` @@ -595,7 +598,7 @@ val op_goal = state_rel s1 (t1:('c,'ffi) closSem$state) /\ evaluate (xs,db,t) = (Rval ws,t1) /\ LIST_REL v_rel vs (REVERSE ws) /\ - LENGTH xs = LENGTH vs /\ op <> Opapp ==> + LENGTH xs = LENGTH vs /\ op <> Opapp /\ op <> ThunkOp ForceThunk ==> ∃res2' t1. evaluate ([compile_op tt op xs],db,t) = (res2',t1) ∧ state_rel s2 t1 ∧ @@ -1252,11 +1255,17 @@ Proof simp [compile_op_def, flatSemTheory.do_app_def] QED +Theorem op_thunk: + ∀th_op. op = ThunkOp th_op ==> ^op_goal +Proof + cheat +QED + Theorem compile_op_correct: ^op_goal Proof EVERY (map assume_tac - [op_refs, op_chars, op_ints, op_words, op_str, op_shifts, + [op_refs, op_chars, op_ints, op_words, op_str, op_shifts, op_thunk, op_floats, op_eq_gc, op_byte_arrays, op_vectors, op_arrays, op_globals, op_blocks, op_ffi, op_byte_copy, op_eval, op_id]) \\ `?this_is_case. this_is_case op` by (qexists_tac `K T` \\ fs []) @@ -1384,6 +1393,7 @@ Proof \\ disch_then drule \\ impl_tac THEN1 (CCONTR_TAC \\ fs []) \\ strip_tac + \\ Cases_on `op = ThunkOp ForceThunk` >- cheat \\ Cases_on `op = Opapp` \\ fs [] THEN1 (fs [compile_op_def,dest_nop_def] \\ rveq diff --git a/compiler/backend/proofs/source_evalProofScript.sml b/compiler/backend/proofs/source_evalProofScript.sml index 9cf8fc088c..7354d14160 100644 --- a/compiler/backend/proofs/source_evalProofScript.sml +++ b/compiler/backend/proofs/source_evalProofScript.sml @@ -622,6 +622,7 @@ Theorem do_app_sim: LIST_REL (sv_rel (v_rel es)) refs refs' /\ result_rel (v_rel es) (v_rel es) r r' Proof + cheat (* rw [s_rel_def] \\ fs [] \\ last_x_assum mp_tac @@ -652,7 +653,7 @@ Proof \\ fs [LIST_REL_REPLICATE_same, EVERY2_LUPDATE_same, LIST_REL_APPEND_EQ] \\ TRY (Cases_on ‘ys’ using SNOC_CASES \\ gs[SNOC_APPEND, REVERSE_APPEND]) \\ TRY (fs [LIST_REL_EL_EQN, EVERY2_REVERSE1] \\ NO_TAC) - \\ imp_res_tac fpSemPropsTheory.fp_translate_cases \\ rveq \\ gs[] + \\ imp_res_tac fpSemPropsTheory.fp_translate_cases \\ rveq \\ gs[] *) QED Theorem pairarg_to_pair_map: @@ -968,6 +969,7 @@ val eval_simulation_setup = setup (` Triviality eval_simulation_App: ^(#get_goal eval_simulation_setup `Case ([App _ _])`) Proof + cheat (* rw [] \\ reverse (fs [pair_case_eq, result_case_eq] \\ rveq \\ fs []) \\ insts_tac @@ -1062,7 +1064,7 @@ Proof \\ insts_tac \\ fs [s_rel_def] \\ rveq \\ fs [] \\ simp [state_component_equality] - \\ rw [] \\ fs [] + \\ rw [] \\ fs [] *) QED Triviality eval_simulation_Denv: @@ -1548,6 +1550,7 @@ Theorem evaluate_is_record_forward: recorded_orac_wf (ci_comp ci) (orac_s s'.eval_state).oracle) ) Proof + cheat (* then_select_goals [``Case [App _ _]``] ( ho_match_mp_tac (name_ind_cases [] full_evaluate_ind) \\ rpt conj_tac @@ -1582,7 +1585,7 @@ Proof \\ eval_cases_tac \\ fs [Q.ISPEC `(a, b)` EQ_SYM_EQ] \\ rpt (drule_then irule record_forward_trans_sym) - \\ simp [record_forward_refl] + \\ simp [record_forward_refl] *) QED val agrees_tac = (drule_then irule orac_agrees_backward) @@ -1651,6 +1654,7 @@ val insert_oracle_correct_setup = setup ( Triviality insert_oracle_correct_App: ^(#get_goal insert_oracle_correct_setup `Case (_, [App _ _])`) Proof + cheat (* rw [] \\ fs [pair_case_eq, result_case_eq] \\ rveq \\ fs [] \\ fs [bool_case_eq] \\ rveq \\ fs [] \\ Cases_on ‘getOpClass op’ \\ gs[] @@ -1688,7 +1692,7 @@ Proof \\ simp [] ) \\ eval_cases_tac - \\ Cases_on ‘st'.fp_state.canOpt = FPScope fpValTree$Opt’ \\ gs[shift_fp_opts_def] + \\ Cases_on ‘st'.fp_state.canOpt = FPScope fpValTree$Opt’ \\ gs[shift_fp_opts_def] *) QED Triviality insert_oracle_correct_Denv: @@ -1793,6 +1797,7 @@ Theorem evaluate_record_suffix: record_forward s''.eval_state s'.eval_state )) Proof + cheat (* ho_match_mp_tac full_evaluate_ind \\ rpt conj_tac \\ rpt (gen_tac ORELSE disch_tac) @@ -1818,7 +1823,7 @@ Proof \\ NO_TAC) \\ simp [combine_dec_result_def, shift_fp_opts_def] \\ rename1 ‘st2.fp_state.canOpt = FpScope fpValTree$Opt’ - \\ Cases_on ‘st2.fp_state.canOpt = FpScope fpValTree$Opt’ \\ gs[shift_fp_opts_def] + \\ Cases_on ‘st2.fp_state.canOpt = FpScope fpValTree$Opt’ \\ gs[shift_fp_opts_def] *) QED (* Constructs the oracle from an evaluation by using the recorded @@ -2330,6 +2335,7 @@ Theorem adjust_oracle_evaluate: evaluate_decs (s_adjust_oracle ci (compile_decs o f) s) env ds = (s_adjust_oracle ci (compile_decs o f) s', res)) Proof + cheat (* disch_tac \\ ho_match_mp_tac (name_ind_cases [] full_evaluate_ind) \\ fs [full_evaluate_def] @@ -2379,7 +2385,7 @@ Proof \\ fs [Q.ISPEC `(a, b)` EQ_SYM_EQ] \\ fs [Q.ISPEC `(a, b)` EQ_SYM_EQ, combine_dec_result_eq_Rerr] \\ try (drule_then drule declare_env_is_insert) - \\ fs [declare_env_adjust] + \\ fs [declare_env_adjust] *) QED Triviality adjust_oracle_ev_decs = diff --git a/compiler/backend/proofs/source_to_flatProofScript.sml b/compiler/backend/proofs/source_to_flatProofScript.sml index 8c8b0cfd11..bb6cf20a7f 100644 --- a/compiler/backend/proofs/source_to_flatProofScript.sml +++ b/compiler/backend/proofs/source_to_flatProofScript.sml @@ -985,6 +985,7 @@ val do_app = time Q.prove ( TAKE 1 s1_i1.refs = TAKE 1 s2_i1.refs ∧ result_rel v_rel genv r r_i1 ∧ do_app s1_i1 (astOp_to_flatOp op) vs_i1 = SOME (s2_i1, r_i1)`, + cheat (* rpt gen_tac >> Cases_on `s1` >> Cases_on `s1_i1.refs` >> simp [] >> @@ -1383,7 +1384,7 @@ val do_app = time Q.prove ( \\ rw[sv_rel_cases, result_rel_cases, v_rel_eqns]) >- ((* Eval *) srw_tac[][semanticPrimitivesPropsTheory.do_app_cases, flatSemTheory.do_app_def] - )); + ) *)); Triviality find_recfun: !x funs e comp_map y t. @@ -4076,6 +4077,7 @@ QED Triviality compile_correct_App: ^(#get_goal compile_correct_setup `Case [App _ _]`) Proof + cheat (* rpt disch_tac \\ fs [pair_case_eq] \\ fs [] \\ first_x_assum (drule_then (drule_then drule)) @@ -4291,7 +4293,7 @@ Proof fs [invariant_def, s_rel_cases] >> rpt (TOP_CASE_TAC >> gs[result_rel_cases, semanticPrimitivesTheory.Boolv_def, Boolv_def, v_rel_eqns]) >> TRY COND_CASES_TAC >> gs[] >> - simp[ Once v_rel_rules] + simp[ Once v_rel_rules] *) QED Triviality compile_correct_Scope: diff --git a/compiler/backend/semantics/flatPropsScript.sml b/compiler/backend/semantics/flatPropsScript.sml index 1b98a05127..09832ef62d 100644 --- a/compiler/backend/semantics/flatPropsScript.sml +++ b/compiler/backend/semantics/flatPropsScript.sml @@ -366,13 +366,10 @@ Triviality do_app_add_to_clock_NONE: ==> do_app (s with clock := s.clock + k) op es = NONE Proof - Cases_on `op` - \\ disch_then (mp_tac o SIMP_RULE (srw_ss()) [do_app_def, case_eq_thms]) - \\ rw [] - \\ rw [do_app_def] - \\ fs [case_eq_thms, pair_case_eq] \\ rw [] \\ fs [] - \\ rpt (pairarg_tac \\ fs []) - \\ fs [bool_case_eq, case_eq_thms] + strip_tac + \\ Cases_on ‘op’ + \\ gvs [do_app_def,AllCaseEqs(),semanticPrimitivesTheory.store_alloc_def] + \\ rw [] \\ gvs [] \\ fs [IS_SOME_EXISTS,CaseEq"option",CaseEq"store_v"] QED @@ -398,6 +395,11 @@ Proof \\ rw [] \\ fs [pmatch_ignore_clock] \\ fs [case_eq_thms, pair_case_eq, bool_case_eq, CaseEq"match_result"] \\ rw [] \\ fs [dec_clock_def] + >- + (gvs [CaseEq "sum",CaseEq"bool"] + \\ gvs [CaseEq"prod"] + \\ Cases_on ‘v1 = Rerr (Rabort Rtimeout_error)’ \\ gvs [] + \\ gvs [AllCaseEqs()]) \\ map_every imp_res_tac [do_app_add_to_clock_NONE, do_app_add_to_clock] \\ fs [] @@ -418,13 +420,10 @@ Theorem do_app_io_events_mono: do_app ^s op vs = SOME (t, r) ⇒ s.ffi.io_events ≼ t.ffi.io_events Proof - rw [do_app_def] \\ fs [case_eq_thms, pair_case_eq, bool_case_eq] - \\ rw [] \\ fs [] - \\ rpt (pairarg_tac \\ fs []) \\ rw [] - \\ fs [semanticPrimitivesTheory.store_assign_def, - semanticPrimitivesTheory.store_lookup_def, - ffiTheory.call_FFI_def] - \\ rw [] \\ every_case_tac \\ fs [] \\ rw [] + rw [do_app_def] \\ gvs [AllCaseEqs()] + \\ gvs [semanticPrimitivesTheory.store_alloc_def, + ffiTheory.call_FFI_def] + \\ gvs [AllCaseEqs()] QED Theorem evaluate_io_events_mono: @@ -1158,7 +1157,6 @@ Proof \\ rfs [EL_MAP] QED - val sv_rel_cases = semanticPrimitivesPropsTheory.sv_rel_cases Theorem simple_do_app_thm: @@ -1176,6 +1174,18 @@ Proof \\ simp [Once do_app_def] \\ simp [case_eq_thms, bool_case_eq, pair_case_eq] \\ simp_tac bool_ss [PULL_EXISTS, DISJ_IMP_THM, FORALL_AND_THM] + \\ Cases_on ‘∃t. op = ThunkOp t’ + >- + (gvs [] \\ gvs [AllCaseEqs()] \\ rw [] \\ gvs [do_app_def] + \\ rpt (pairarg_tac \\ gvs []) + >- + (drule_then (drule_then drule) simple_state_rel_store_alloc + \\ simp [Once sv_rel_cases,PULL_EXISTS] + \\ disch_then drule \\ strip_tac \\ gvs []) + >- + (drule_then (drule_then drule) simple_state_rel_store_assign + \\ simp [Once sv_rel_cases,PULL_EXISTS] + \\ disch_then drule \\ strip_tac \\ gvs [])) \\ Cases_on `?x. op = FFI x` >- ( fs [GSYM AND_IMP_INTRO] @@ -1374,6 +1384,7 @@ Theorem flat_evaluate_def = flat_evaluate_def Definition store_v_vs_def[simp]: store_v_vs (Varray vs) = vs /\ store_v_vs (Refv v) = [v] /\ + store_v_vs (Thunk b v) = [v] /\ store_v_vs (W8array xs) = [] End diff --git a/compiler/backend/semantics/flatSemScript.sml b/compiler/backend/semantics/flatSemScript.sml index 3fac9d2786..ea663b8a9d 100644 --- a/compiler/backend/semantics/flatSemScript.sml +++ b/compiler/backend/semantics/flatSemScript.sml @@ -534,6 +534,16 @@ Definition do_app_def: | _ => NONE) | (Id, [v1]) => SOME (s, Rval v1) + | (ThunkOp th_op, vs) => + (case (th_op,vs) of + | (AllocThunk b, [v]) => + (let (r,n) = store_alloc (Thunk b v) s.refs in + SOME (s with refs := r, Rval (Loc F n))) + | (UpdateThunk b, [Loc _ lnum; v]) => + (case store_assign lnum (Thunk b v) s.refs of + | SOME r => SOME (s with refs := r, Rval (Conv NONE [])) + | NONE => NONE) + | _ => NONE) | _ => NONE End @@ -676,6 +686,24 @@ Definition do_eval_def: | _ => NONE) End +Definition dest_thunk_def: + dest_thunk [Loc _ n] st = + (case store_lookup n st of + | SOME (Thunk T v) => SOME (INL v) + | SOME (Thunk F v) => SOME (INR v) + | _ => NONE) ∧ + dest_thunk vs st = NONE +End + +Definition update_thunk_def: + update_thunk [Loc _ n] st [v] = store_assign n (Thunk T v) st ∧ + update_thunk _ st _ = NONE +End + +Definition AppUnit_def: + AppUnit x = flatLang$App None Opapp [x; Con None NONE []] +End + Definition evaluate_def: (evaluate (env:v flatSem$environment) ^s ([]:flatLang$exp list) = (s,Rval [])) ∧ @@ -740,10 +768,25 @@ Definition evaluate_def: | (s, NONE) => (s, Rval [retv]) | (s, SOME e) => (s, Rerr e)) | NONE => (s, Rerr (Rabort Rtype_error))) + else if op = ThunkOp ForceThunk then + (case dest_thunk vs s.refs of + | NONE => (s, Rerr (Rabort Rtype_error)) + | SOME (INL v) => (s, Rval [v]) + | SOME (INR f) => + if s.clock = 0 then + (s, Rerr (Rabort Rtimeout_error)) + else + case evaluate <| v := [("f",f)] |> (dec_clock s) + [AppUnit (Var_local None "f")] of + | (s, Rval vs2) => + (case update_thunk vs s.refs vs2 of + | NONE => (s, Rerr (Rabort Rtype_error)) + | SOME refs => (s with refs := refs, Rval vs2)) + | (s, Rerr e) => (s, Rerr e)) else - (case (do_app s op (REVERSE vs)) of - | NONE => (s, Rerr (Rabort Rtype_error)) - | SOME (s',r) => (s', evaluate$list_result r)) + (case (do_app s op (REVERSE vs)) of + | NONE => (s, Rerr (Rabort Rtype_error)) + | SOME (s',r) => (s', evaluate$list_result r)) | res => res) ∧ (evaluate env s [If _ e1 e2 e3] = case fix_clock s (evaluate env s [e1]) of @@ -847,9 +890,8 @@ QED Theorem do_app_cases = ``do_app st op vs = SOME (st',v)`` |> - (SIMP_CONV (srw_ss()++COND_elim_ss) [PULL_EXISTS, do_app_def, eqs, pair_case_eq, pair_lam_lem] THENC - SIMP_CONV (srw_ss()++COND_elim_ss) [LET_THM, eqs] THENC - ALL_CONV) + (SIMP_CONV (srw_ss()++COND_elim_ss) [PULL_EXISTS, do_app_def, eqs, pair_case_eq, pair_lam_lem, CaseEq "thunk_op"] THENC + SIMP_CONV (srw_ss()++COND_elim_ss) [LET_THM, eqs]) Theorem do_app_const: do_app s op vs = SOME (s',r) ⇒ s.clock = s'.clock ∧ s.c = s'.c diff --git a/compiler/backend/source_to_flatScript.sml b/compiler/backend/source_to_flatScript.sml index 48e1ba2bdb..f9e932c04f 100644 --- a/compiler/backend/source_to_flatScript.sml +++ b/compiler/backend/source_to_flatScript.sml @@ -130,6 +130,7 @@ Definition astOp_to_flatOp_def: | ConfigGC => flatLang$ConfigGC | FFI string => flatLang$FFI string | Eval => Eval + | ThunkOp t => ThunkOp t (* default element *) | _ => flatLang$ConfigGC End diff --git a/compiler/inference/inferScript.sml b/compiler/inference/inferScript.sml index 481d55ad52..3f94c62619 100644 --- a/compiler/inference/inferScript.sml +++ b/compiler/inference/inferScript.sml @@ -655,7 +655,10 @@ Definition op_to_string_def: (op_to_string Eval = (implode "Eval", 6)) ∧ (op_to_string Env_id = (implode "Env_id", 1)) ∧ (op_to_string ListAppend = (implode "ListAppend", 2)) ∧ - (op_to_string (FFI _) = (implode "FFI", 2)) + (op_to_string (FFI _) = (implode "FFI", 2)) ∧ + (op_to_string (ThunkOp ForceThunk) = (implode "ForceThunk", 1)) ∧ + (op_to_string (ThunkOp (AllocThunk _)) = (implode "AllocThunk", 1)) ∧ + (op_to_string (ThunkOp (UpdateThunk _)) = (implode "UpdateThunk", 2)) End Overload Tem[local,inferior] = ``Infer_Tapp []`` diff --git a/compiler/parsing/fromSexpScript.sml b/compiler/parsing/fromSexpScript.sml index 17d9285925..275c147c8e 100644 --- a/compiler/parsing/fromSexpScript.sml +++ b/compiler/parsing/fromSexpScript.sml @@ -649,6 +649,15 @@ Proof rw[FUN_EQ_THM,sexppat_alt_intro] QED +Definition decode_bool_def: + decode_bool s = if s = "T" then SOME T else + if s = "F" then SOME F else NONE +End + +Definition encode_bool_def: + encode_bool b = if b then "T" else "F" +End + Definition sexpop_def: (sexpop (SX_SYM s) = if s = "OpnPlus" then SOME (Opn Plus) else @@ -740,12 +749,20 @@ Definition sexpop_def: if s = "Aupdate" then SOME Aupdate else if s = "Asubunsafe" then SOME Asub_unsafe else if s = "Aupdateunsafe" then SOME Aupdate_unsafe else + if s = "ForceThunk" then SOME (ThunkOp ForceThunk) else if s = "ConfigGC" then SOME ConfigGC else if s = "Eval" then SOME Eval else if s = "Envid" then SOME Env_id else NONE) ∧ (sexpop (SX_CONS (SX_SYM s) (SX_STR s')) = if s = "FFI" then OPTION_MAP FFI (decode_control s') else NONE ) ∧ + (sexpop (SX_CONS (SX_SYM s) (SX_SYM t)) = + case decode_bool t of + | NONE => NONE + | SOME b => + if s = "AllocThunk" then SOME (ThunkOp (AllocThunk b)) else + if s = "UpdateThunk" then SOME (ThunkOp (UpdateThunk b)) else NONE + ) ∧ (sexpop (SX_CONS (SX_SYM s) (SX_NUM n)) = if s = "Shift8Lsl" then SOME (Shift W8 Lsl n) else if s = "Shift8Lsr" then SOME (Shift W8 Lsr n) else @@ -1406,13 +1423,22 @@ Definition opsexp_def: (opsexp ConfigGC = SX_SYM "ConfigGC") ∧ (opsexp Eval = SX_SYM "Eval") ∧ (opsexp Env_id = SX_SYM "Envid") ∧ - (opsexp (FFI s) = SX_CONS (SX_SYM "FFI") (SEXSTR s)) + (opsexp (FFI s) = SX_CONS (SX_SYM "FFI") (SEXSTR s)) ∧ + (opsexp (ThunkOp ForceThunk) = SX_SYM "ForceThunk") ∧ + (opsexp (ThunkOp (AllocThunk b)) = + SX_CONS (SX_SYM "AllocThunk") (SX_SYM (encode_bool b))) ∧ + (opsexp (ThunkOp (UpdateThunk b)) = + SX_CONS (SX_SYM "UpdateThunk") (SX_SYM (encode_bool b))) End Theorem sexpop_opsexp[simp]: sexpop (opsexp op) = SOME op Proof - Cases_on`op`>>rw[sexpop_def,opsexp_def]>> + Cases_on ‘∃t. op = ThunkOp t’ + >- (gvs [] \\ Cases_on ‘t’ + \\ gvs [sexpop_def,opsexp_def,encode_bool_def,decode_bool_def] + \\ rw [] \\ gvs [AllCaseEqs()]) >> + Cases_on`op`>>fs []>>rw[sexpop_def,opsexp_def] >> TRY(MAP_FIRST rename1 [ ‘Opn c1’, ‘Opb c1’, ‘Opw c2 c1’, ‘Chopb c1’, ‘Shift c1 c2 _’, ‘FP_cmp c1’, ‘FP_uop c1’, ‘FP_bop c1’, ‘FP_top c1’, @@ -1966,6 +1992,7 @@ Proof \\ Cases_on ‘s1’ \\ gvs[sexpop_def] \\ Cases_on ‘s2’ \\ gvs[sexpop_def, AllCaseEqs(), opsexp_def, encode_decode_control] + \\ gvs [encode_bool_def,decode_bool_def,AllCaseEqs()] QED Theorem lopsexp_sexplop: @@ -2155,6 +2182,8 @@ Proof \\ TRY(Cases_on`s`) \\ simp[opsexp_def] \\ TRY(Cases_on`f`) \\ simp[opsexp_def] \\ TRY(Cases_on`r`) \\ simp[opsexp_def] + \\ TRY(Cases_on`t`) \\ simp[opsexp_def] + \\ TRY(Cases_on`b`) \\ simp[opsexp_def] \\ EVAL_TAC QED diff --git a/compiler/repl/evaluate_initScript.sml b/compiler/repl/evaluate_initScript.sml index 656d7f3d0d..4c9c0ef551 100644 --- a/compiler/repl/evaluate_initScript.sml +++ b/compiler/repl/evaluate_initScript.sml @@ -349,6 +349,7 @@ Theorem do_app_ok: (∀v. res = Rval v ⇒ v_ok t v) ∧ (∀v. res = Rerr (Rraise v) ⇒ v_ok t v) Proof + cheat (* strip_tac \\ simp [LET_THM] \\ simp [Once CONJ_COMM] \\ simp [Once (GSYM CONJ_ASSOC)] @@ -679,7 +680,7 @@ Proof gvs[do_app_cases, v_ok_thm] \\ ‘s with <| refs := s.refs; ffi := s.ffi |> = s’ suffices_by gs[] \\ gs[state_component_equality]) - \\ Cases_on ‘op’ \\ gs [] + \\ Cases_on ‘op’ \\ gs [] *) QED Theorem do_app_ok[allow_rebind] = SIMP_RULE (srw_ss()) [LET_THM] do_app_ok; @@ -687,6 +688,7 @@ Theorem do_app_ok[allow_rebind] = SIMP_RULE (srw_ss()) [LET_THM] do_app_ok; Theorem evaluate_ok_Op: op ≠ Opapp ∧ op ≠ Eval ⇒ ^(get_goal "App") Proof + cheat (* strip_tac \\ ‘~ (getOpClass op = EvalOp)’ by (Cases_on ‘op’ \\ gs[]) \\ ‘~ (getOpClass op = FunApp)’ by (Cases_on ‘op’ \\ gs[]) @@ -716,7 +718,7 @@ Proof \\ every_case_tac \\ gs[] \\ rveq \\ gs[]) \\ irule env_rel_update \\ first_assum (irule_at Any) - \\ gs [FUN_FMAP_SUBMAP_SUBSET, COUNT_MONO] + \\ gs [FUN_FMAP_SUBMAP_SUBSET, COUNT_MONO] *) QED Theorem do_opapp_cases[local] = semanticPrimitivesPropsTheory.do_opapp_cases; diff --git a/compiler/repl/evaluate_skipScript.sml b/compiler/repl/evaluate_skipScript.sml index 139788fd70..a2e934f2ed 100644 --- a/compiler/repl/evaluate_skipScript.sml +++ b/compiler/repl/evaluate_skipScript.sml @@ -125,8 +125,9 @@ Theorem ref_rel_refl: (∀x. P x x) ⇒ ref_rel P x x Proof + cheat (* Cases_on ‘x’ \\ rw [ref_rel_def] - \\ Induct_on ‘l’ \\ gs [] + \\ Induct_on ‘l’ \\ gs [] *) QED Definition state_rel_def: @@ -654,6 +655,7 @@ Theorem state_rel_store_assign: (store_assign n v s.refs) (store_assign m w t.refs) Proof + cheat (* rw [OPTREL_def, store_assign_def, state_rel_def] \\ ‘n < LENGTH s.refs ∧ m < LENGTH t.refs’ by (qpat_x_assum ‘INJ ($' fr) _ _’ mp_tac @@ -684,7 +686,7 @@ Proof \\ qpat_x_assum ‘INJ ($' fr) _ _’ mp_tac \\ qpat_x_assum ‘FLOOKUP fr n1 = SOME _’ mp_tac \\ qpat_x_assum ‘FLOOKUP fr n = SOME _’ mp_tac - \\ rw [flookup_thm, INJ_DEF] \\ gs [] + \\ rw [flookup_thm, INJ_DEF] \\ gs [] *) QED Theorem v_rel_v_to_list: @@ -848,6 +850,7 @@ Theorem do_app_update: res_rel (v_rel fr1 ft1 fe1) (v_rel fr1 ft1 fe1) res res1) res res1 Proof + cheat (* strip_tac \\ Cases_on ‘op = Env_id’ \\ gs [] >- ( @@ -1796,7 +1799,7 @@ Proof "store_v", "v"]] \\ rpt (irule_at Any SUBMAP_REFL) \\ gs [] \\ first_assum (irule_at Any) \\ gs []) - \\ Cases_on ‘op’ \\ gs [] + \\ Cases_on ‘op’ \\ gs [] *) QED (* TODO Move up *) @@ -1833,6 +1836,7 @@ QED Theorem evaluate_update_Op: op ≠ Opapp ∧ op ≠ Eval ⇒ ^(get_goal "App") Proof + cheat (* rw [evaluate_def] \\ Cases_on ‘getOpClass op’ >- (Cases_on ‘op’ \\ gs[]) >- (Cases_on ‘op’ \\ gs[]) @@ -1912,7 +1916,7 @@ Proof \\ last_x_assum $ irule_at Any \\ last_x_assum $ irule_at Any \\ last_x_assum $ irule_at Any - \\ gs [state_rel_def]) + \\ gs [state_rel_def]) *) QED Theorem do_opapp_update: diff --git a/semantics/alt_semantics/proofs/bigClockScript.sml b/semantics/alt_semantics/proofs/bigClockScript.sml index 082e4c3583..b225a3493d 100644 --- a/semantics/alt_semantics/proofs/bigClockScript.sml +++ b/semantics/alt_semantics/proofs/bigClockScript.sml @@ -38,10 +38,10 @@ Theorem big_unclocked_unchanged[local]: SND r1 ≠ Rerr (Rabort Rtimeout_error) ∧ s.clock = (FST r1).clock) Proof - ho_match_mp_tac evaluate_ind >> rw [] >> - fs[do_app_cases, shift_fp_opts_def, do_fprw_def, compress_if_bool_def] >> - rw [] >> fs [] >> - every_case_tac >> fs[] >> rveq >> fs[] + ho_match_mp_tac evaluate_ind \\ rw [] + \\ gvs [shift_fp_opts_def, compress_if_bool_def, AllCaseEqs()] + \\ gvs [do_fprw_def,AllCaseEqs()] + \\ gvs [do_app_cases,AllCaseEqs(),oneline thunk_op_def,store_alloc_def] QED Triviality lemma: @@ -80,6 +80,7 @@ Theorem big_unclocked_ignore: ⇒ evaluate_match F env (s with clock := count) v pes err_v (st' with clock := count, r)) Proof + cheat (* ho_match_mp_tac evaluate_ind >> rw [] >> rw [Once evaluate_cases, shift_fp_opts_def]>> @@ -130,7 +131,7 @@ Proof rw[] >> NO_TAC) >> rfs [] >> - metis_tac [with_clock_refs] + metis_tac [with_clock_refs] *) QED Theorem with_clock_with_clock[local]: @@ -456,6 +457,7 @@ Theorem big_clocked_total_lem[local]: !count_e env s. ∃s' r. evaluate T env (s with clock := FST count_e) (SND count_e) (s', r) Proof + cheat (* ho_match_mp_tac ind >> rw [] >> `?count e. count_e = (count,e)` by (PairCases_on `count_e` >> fs []) >> @@ -630,7 +632,7 @@ Proof >- ((* FpOptimise not Strict*) `exp_size e' < exp_size (FpOptimise f e')` by srw_tac [ARITH_ss] [exp_size_def] >> - metis_tac [result_nchotomy, optionTheory.option_nchotomy, error_result_nchotomy, with_clock_clock]) + metis_tac [result_nchotomy, optionTheory.option_nchotomy, error_result_nchotomy, with_clock_clock]) *) QED Theorem big_clocked_total: @@ -673,13 +675,14 @@ Theorem big_clocked_timeout_0: ⇒ (s'.clock = 0)) Proof + cheat (* ho_match_mp_tac evaluate_ind >> rw [] >> fs[do_app_cases, opClass_cases] >> rw [] >> fs [] >> every_case_tac >> fs[] >> rveq >> fs[] >> - gs[do_fprw_def, compress_if_bool_def] >> every_case_tac >> gs[] + gs[do_fprw_def, compress_if_bool_def] >> every_case_tac >> gs[] *) QED Theorem big_clocked_unclocked_equiv_timeout: diff --git a/semantics/alt_semantics/proofs/bigSmallEquivScript.sml b/semantics/alt_semantics/proofs/bigSmallEquivScript.sml index 3660d1dd84..8d3e318bd4 100644 --- a/semantics/alt_semantics/proofs/bigSmallEquivScript.sml +++ b/semantics/alt_semantics/proofs/bigSmallEquivScript.sml @@ -72,6 +72,7 @@ Theorem big_exp_to_small_exp: evaluate_match ck env s v pes err_v r ⇒ (ck = F) ⇒ small_eval_match env (to_small_st s) s.fp_state v pes err_v (to_small_res r)) Proof + cheat (* ho_match_mp_tac evaluate_ind >> srw_tac[][small_eval_log, small_eval_if, small_eval_match, small_eval_lannot, small_eval_handle, small_eval_let, small_eval_letrec, small_eval_tannot, to_small_res_def, small_eval_raise] @@ -960,7 +961,7 @@ Proof >- metis_tac [small_eval_match_rules, FST, pair_CASES, to_small_st_def] >- metis_tac [small_eval_match_rules, FST, pair_CASES, to_small_st_def] >- metis_tac [small_eval_match_rules, FST, pair_CASES, to_small_st_def] - >- metis_tac [small_eval_match_rules] + >- metis_tac [small_eval_match_rules] *) QED Theorem evaluate_ctxts_cons: @@ -1076,6 +1077,7 @@ Theorem one_step_backward: evaluate_state ck (env',s with <| refs := refs'; ffi := ffi' ; fp_state := fp' |>,e',c') bv ⇒ evaluate_state ck (env,s with <| refs := refs; ffi := ffi ; fp_state := fp|>,e,c) bv Proof + cheat (* rw[e_step_def] >> Cases_on `e` >> gvs[] >- ( Cases_on `e''` >> gvs[push_def, return_def] @@ -1155,7 +1157,7 @@ Proof gvs[AllCaseEqs()] >> gvs[evaluate_state_cases, evaluate_ctxts_cons, evaluate_ctxt_cases, evaluate_ctxts_cons, evaluate_ctxt_cases, ADD1, SF SFY_ss, getOpClass_opClass] - ) + ) *) QED Theorem evaluate_ctxts_type_error: @@ -1215,6 +1217,7 @@ Theorem one_step_backward_type_error: ⇒ evaluate_state ck (env,s with fp_state := fp,e,c) (s with fp_state := fp', Rerr (Rabort a)) Proof + cheat (* srw_tac[][e_step_def] >> cases_on `e` >> full_simp_tac(srw_ss())[] @@ -1339,7 +1342,7 @@ Proof rewrite_tac[state_update_fp_later] >> ((irule_at Any evaluate_ctxts_type_error_matchable >> srw_tac[][state_component_equality] >> rpt $ irule_at Any EQ_REFL) ORELSE - metis_tac[do_con_check_build_conv,NOT_SOME_NONE]) + metis_tac[do_con_check_build_conv,NOT_SOME_NONE]) *) QED Theorem small_exp_to_big_exp: @@ -1954,6 +1957,7 @@ Theorem big_exp_to_small_exp_timeout_lemma: ∀s'. r = (s', Rerr (Rabort Rtimeout_error)) ∧ ck ⇒ ∃ fp. e_step_to_match env (to_small_st s) s.fp_state v pes (to_small_st s') fp) Proof + cheat (* ho_match_mp_tac evaluate_strongind >> rw[] >- ( (* Raise *) irule_at Any $ cj 2 RTC_rules >> @@ -2167,7 +2171,7 @@ Proof >- ( (* match *) simp[Once e_step_to_match_cases] >> qexists_tac ‘fp’ >> disj2_tac >> simp[Once to_small_st_def, SF SFY_ss] - ) + ) *) QED Theorem big_exp_to_small_exp_timeout: @@ -2471,6 +2475,7 @@ QED Theorem evaluate_ctxt_T_total: ∀env s c v. ∃r. evaluate_ctxt T env s c v r Proof + cheat (* rw[] >> simp[Once evaluate_ctxt_cases] >> Cases_on `c` >> gvs[SF DNF_ss] >- ( qspecl_then [`l0`,`env`,`s`] assume_tac big_clocked_list_total >> gvs[] >> @@ -2518,7 +2523,7 @@ Proof qspecl_then [`l0`,`env`,`s`] assume_tac big_clocked_list_total >> gvs[] >> PairCases_on `r` >> Cases_on `r1` >> gvs[SF SFY_ss] >> metis_tac[do_con_check_build_conv] - ) + ) *) QED Theorem evaluate_ctxts_T_total: @@ -2702,5 +2707,4 @@ Proof ) QED - val _ = export_theory (); diff --git a/semantics/alt_semantics/proofs/funBigStepEquivScript.sml b/semantics/alt_semantics/proofs/funBigStepEquivScript.sml index 7e5e6cb681..d0b2f4bf60 100644 --- a/semantics/alt_semantics/proofs/funBigStepEquivScript.sml +++ b/semantics/alt_semantics/proofs/funBigStepEquivScript.sml @@ -44,6 +44,7 @@ Theorem evaluate_eq_run_eval_list: evaluate_match s env v e errv = (I ## list_result) (run_eval_match env v e errv s)) Proof + cheat (* ho_match_mp_tac evaluate_ind >> rw[evaluate_def,run_eval_def, result_return_def,result_bind_def, Excl"getOpClass_def"] >> gvs [Excl"getOpClass_def"] @@ -64,7 +65,7 @@ Proof res_tac >> gs[state_component_equality]) >> TRY (rpt $ pop_assum mp_tac >> ntac 2 (TOP_CASE_TAC >> gs[do_fpoptimise_LENGTH]) >> NO_TAC) >> - prove_tac + prove_tac *) QED Theorem functional_evaluate_list: @@ -89,6 +90,7 @@ Theorem evaluate_decs_eq_run_eval_decs: (s.eval_state = NONE ⇒ evaluate_decs s env decs = run_eval_decs env s decs) Proof + cheat (* recInduct evaluate_decs_ind >> rw[evaluate_decs_def,run_eval_dec_def,run_eval_dec_def] >> every_case_tac >> @@ -104,7 +106,7 @@ Proof rpt (qpat_x_assum ‘∀x. _’ kall_tac) >> gvs [evaluate_eq_run_eval_list] >> gvs [run_eval_def,result_return_def,result_bind_def] >> - gvs [EVERY_MEM,EXISTS_MEM] + gvs [EVERY_MEM,EXISTS_MEM] *) QED Theorem functional_evaluate_decs: diff --git a/semantics/alt_semantics/proofs/interpScript.sml b/semantics/alt_semantics/proofs/interpScript.sml index 5fa999751b..1b78b1bc75 100644 --- a/semantics/alt_semantics/proofs/interpScript.sml +++ b/semantics/alt_semantics/proofs/interpScript.sml @@ -139,7 +139,8 @@ Theorem getOpClass_opClass: (getOpClass op = Icing ⇔ opClass op Icing) ∧ (getOpClass op = Reals ⇔ opClass op Reals) Proof - Cases_on ‘op’ >> gs[getOpClass_def, opClass_cases] + cheat (* + Cases_on ‘op’ >> gs[getOpClass_def, opClass_cases] *) QED Theorem evaluate_strict_fp_sticky: @@ -165,6 +166,7 @@ Proof ho_match_mp_tac evaluate_ind >> rw[evaluate_cases, shift_fp_opts_def] QED +(* Theorem run_eval_def: (!^st env l. run_eval env (Lit l) @@ -360,6 +362,7 @@ Theorem run_eval_def: raise (Rabort Rtype_error) od) Proof + cheat (* rw [GSYM evaluate_run_eval, FUN_EQ_THM, result_raise_def, result_return_def, result_bind_def, get_store_def, set_store_def] >> rw [Once evaluate_cases] @@ -492,8 +495,9 @@ Proof >- (every_case_tac >> rw [] >> fs [GSYM evaluate_run_eval_match, GSYM evaluate_run_eval] >> - rw [Once evaluate_cases]) + rw [Once evaluate_cases]) *) QED +*) Definition run_eval_dec_def: (run_eval_dec env ^st (Dlet _ p e) = diff --git a/semantics/alt_semantics/proofs/itree_semanticsEquivScript.sml b/semantics/alt_semantics/proofs/itree_semanticsEquivScript.sml index 8c978b8e03..ff33d4ef57 100644 --- a/semantics/alt_semantics/proofs/itree_semanticsEquivScript.sml +++ b/semantics/alt_semantics/proofs/itree_semanticsEquivScript.sml @@ -56,6 +56,7 @@ Theorem do_app_rel: (do_app st op vs) (OPTION_MAP (λ(a,b). (FST a, b)) (do_app (st, ffi) op vs)) Proof + cheat (* rw[] >> reverse $ Cases_on `do_app (st,ffi) op vs` >> gvs[] >- ( PairCases_on `x` >> gvs[semanticPrimitivesPropsTheory.do_app_cases] >> @@ -63,7 +64,7 @@ Proof ) >> Cases_on `do_app st op vs` >> gvs[] >> PairCases_on `x` >> gvs[do_app_cases, semanticPrimitivesTheory.do_app_def, store_alloc_def] >> - every_case_tac >> gvs[] + every_case_tac >> gvs[] *) QED Theorem ctxt_rel_fix_fp_state: @@ -98,6 +99,7 @@ Theorem application_rel: (application op env st fp vs cs1) (application op env (st,ffi) fp vs cs2) Proof + cheat (* rw[] >> drule do_app_rel >> disch_then $ qspecl_then [`vs`,`st`,`ffi`] assume_tac >> Cases_on ‘getOpClass op’ @@ -170,7 +172,7 @@ Proof simp[step_result_rel_cases, AllCaseEqs()] >> gvs[ctxt_rel_def] >> simp[ctxt_frame_rel_cases]) >- (gs[step_result_rel_cases, ctxt_rel_fix_fp_state] - )) + )) *) QED Theorem application_rel_FFI_type_error: @@ -562,6 +564,7 @@ Theorem step_result_rel_single_FFI_error: ⇒ ∃lnum env. estep ea = Effi s conf ws lnum env (FST $ SND ea) (TL $ SND $ SND $ SND $ SND ea) Proof + cheat (* rpt $ PairCases >> rw[e_step_def] >> gvs[AllCaseEqs(), SF smallstep_ss] >> gvs[cml_application_thm, AllCaseEqs(), SF smallstep_ss] >> gvs[semanticPrimitivesPropsTheory.do_app_cases, AllCaseEqs()] >> @@ -569,7 +572,7 @@ Proof gvs[GSYM ctxt_rel_def, ctxt_frame_rel_cases] >> pairarg_tac >> gvs[] >> simp[SF itree_ss, application_def] >> gvs[call_FFI_def, AllCaseEqs()] >> gs[semanticPrimitivesTheory.do_fprw_def] >> every_case_tac >> gs[] >> - simp[combinTheory.o_DEF, stringTheory.IMPLODE_EXPLODE_I] + simp[combinTheory.o_DEF, stringTheory.IMPLODE_EXPLODE_I] *) QED Theorem dstep_result_rel_single_FFI_strong: @@ -887,11 +890,12 @@ Theorem do_app_not_SharedMem: semanticPrimitives$do_app s op vs ≠ SOME (v, Rerr (Rabort (Rffi_error (Final_event (SharedMem s') conf ws outcome)))) Proof + cheat (* rpt strip_tac >> gvs[DefnBase.one_line_ify NONE semanticPrimitivesTheory.do_app_def, AllCaseEqs(),call_FFI_def] >> rw[] >> - pairarg_tac >> fs[] + pairarg_tac >> fs[] *) QED Theorem application_not_SharedMem: diff --git a/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml b/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml index 211702d45e..5e05277daf 100644 --- a/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml +++ b/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml @@ -580,6 +580,7 @@ Theorem application_thm: | SOME (v1,Rval v') => return env v1 fp v' c | SOME (v1,Rraise v) => Estep (env,v1,fp,Exn v,c)) Proof + cheat (* rpt strip_tac >> Cases_on ‘getOpClass op’ >> gs[] >> TOP_CASE_TAC >> gs[application_def] >- ( @@ -588,7 +589,7 @@ Proof >- ( Cases_on ‘op’ >> gs[application_def] >> every_case_tac >> gs[do_app_def] >> pop_assum $ mp_tac >> - rpt (TOP_CASE_TAC >> gvs[SF itree_ss]) >> gs[store_alloc_def]) + rpt (TOP_CASE_TAC >> gvs[SF itree_ss]) >> gs[store_alloc_def]) *) QED Theorem application_FFI_results: diff --git a/semantics/alt_semantics/proofs/smallStepPropsScript.sml b/semantics/alt_semantics/proofs/smallStepPropsScript.sml index 8d42d4943c..820777e4aa 100644 --- a/semantics/alt_semantics/proofs/smallStepPropsScript.sml +++ b/semantics/alt_semantics/proofs/smallStepPropsScript.sml @@ -745,6 +745,7 @@ Theorem small_eval_app_err: e_step_reln^* (env0,s,fp,Val v1,[Capp op v0 () es,env]) (env',s',fp'',e',c') ∧ e_step (env',s',fp'',e',c') = Eabort (fp', Rtype_error) Proof + cheat (* ho_match_mp_tac small_eval_list_ind >> simp[] >> srw_tac[][] >> srw_tac[boolSimps.DNF_ss][Once RTC_CASES1,e_step_reln_def] >- ( srw_tac[][Once e_step_def,continue_def,application_thm] >> @@ -759,7 +760,7 @@ Proof full_simp_tac(srw_ss())[] >> first_x_assum(qspecl_then[`op`,`env'`,`v`,`v1::v0`]mp_tac) >> impl_tac >- simp[] >> - metis_tac[transitive_RTC,transitive_def] + metis_tac[transitive_RTC,transitive_def] *) QED Theorem small_eval_app_err_more: @@ -775,6 +776,7 @@ Theorem small_eval_app_err_more: e_step_reln^* (env0,s,fp,Val v1,[Capp op v0 () es,env]) (env',s',fp'',e',c') ∧ e_step (env',s',fp'',e',c') = Eabort (fp', Rtype_error) Proof + cheat (* ho_match_mp_tac small_eval_list_ind >> simp[] >> srw_tac[][] >> srw_tac[boolSimps.DNF_ss][Once RTC_CASES1,e_step_reln_def] >- ( srw_tac[][Once e_step_def,continue_def,application_thm] >> @@ -789,7 +791,7 @@ Proof full_simp_tac(srw_ss())[] >> first_x_assum(qspecl_then[`op`,`env'`,`v`,`v1::v0`]mp_tac) >> impl_tac >- simp[] >> - metis_tac[transitive_RTC,transitive_def] + metis_tac[transitive_RTC,transitive_def] *) QED val _ = temp_delsimps ["getOpClass_def"] From 3e4c416c3283d6ade13f0767187da93ba49011fb Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Wed, 11 Dec 2024 23:33:00 +0100 Subject: [PATCH 007/112] Get more files to build --- compiler/bootstrap/translation/sexp_parserProgScript.sml | 3 +++ compiler/dafny/translation/dafny_compilerProgScript.sml | 3 +++ icing/floatToRealProofsScript.sml | 3 ++- icing/optPlannerProofsScript.sml | 3 ++- icing/pull_wordsScript.sml | 3 ++- icing/pureExpsScript.sml | 1 + icing/source_to_source2ProofsScript.sml | 9 ++++++--- 7 files changed, 19 insertions(+), 6 deletions(-) diff --git a/compiler/bootstrap/translation/sexp_parserProgScript.sml b/compiler/bootstrap/translation/sexp_parserProgScript.sml index e9f6253a9d..9611ad3c48 100644 --- a/compiler/bootstrap/translation/sexp_parserProgScript.sml +++ b/compiler/bootstrap/translation/sexp_parserProgScript.sml @@ -291,6 +291,9 @@ val sexppat_alt_side = Q.prove( rw[Once(theorem"sexppat_alt_side_def")]) |> update_precondition; +val r = translate decode_bool_def; +val r = translate encode_bool_def; + val r = translate (fromSexpTheory.sexpop_def |> REWRITE_RULE [decode_control_eq]); diff --git a/compiler/dafny/translation/dafny_compilerProgScript.sml b/compiler/dafny/translation/dafny_compilerProgScript.sml index 673d5acea7..a117df0712 100644 --- a/compiler/dafny/translation/dafny_compilerProgScript.sml +++ b/compiler/dafny/translation/dafny_compilerProgScript.sml @@ -26,6 +26,9 @@ val r = translate simpleSexpParseTheory.strip_dot_def; val r = translate simpleSexpParseTheory.escape_string_def; val r = translate simpleSexpParseTheory.print_sexp_def; +val r = translate fromSexpTheory.encode_bool_def; +val r = translate fromSexpTheory.decode_bool_def; + val r = translate fromSexpTheory.listsexp_def; val r = translate fromSexpTheory.locnsexp_def; val r = translate fromSexpTheory.locssexp_def; diff --git a/icing/floatToRealProofsScript.sml b/icing/floatToRealProofsScript.sml index 4091b9c18f..367c73b74e 100644 --- a/icing/floatToRealProofsScript.sml +++ b/icing/floatToRealProofsScript.sml @@ -543,6 +543,7 @@ Theorem perform_rewrites_real_id_correct: evaluate st1 env [realify e]= (st2 with fp_state := st2.fp_state with choices := choices, Rval r) Proof + cheat (* ho_match_mp_tac perform_rewrites_ind \\ rpt strip_tac \\ fs[perform_rewrites_def] \\ TRY (no_change_tac \\ NO_TAC) >- ( @@ -811,7 +812,7 @@ Proof \\ get_IH ‘evaluate _ _ [realify (perform_rewrites _ _ _ _)] = _’ \\ impl_tac >- gs[] \\ strip_tac - \\ gs[evaluate_def, semState_comp_eq, fpState_component_equality] + \\ gs[evaluate_def, semState_comp_eq, fpState_component_equality] *) QED Theorem is_real_id_list_perform_rewrites_lift: diff --git a/icing/optPlannerProofsScript.sml b/icing/optPlannerProofsScript.sml index 84e311d338..08c2e441e9 100644 --- a/icing/optPlannerProofsScript.sml +++ b/icing/optPlannerProofsScript.sml @@ -206,6 +206,7 @@ Theorem canonicalize_app_upper_bound: fp_comm_gen FP_Add; fp_comm_gen FP_Mul; fp_assoc_gen FP_Add; fp_assoc_gen FP_Mul] Proof + cheat (* measureInduct_on ‘exp_size e’ >> simp[Once canonicalize_app_def, CaseEq"op", CaseEq"list"] >> rpt strip_tac >> gs[CaseEq "exp", CaseEq "fp_bop", CaseEq"list", CaseEq"op"] @@ -224,7 +225,7 @@ Proof >> imp_res_tac MEM_MAP_plan_to_path_index >> first_x_assum $ qspec_then ‘App (FP_bop FP_Mul) [v453; v153]’ mp_tac >> gs[astTheory.exp_size_def] - >> rpt $ disch_then drule >> gs[] + >> rpt $ disch_then drule >> gs[] *) QED fun trivial_case_tac t = diff --git a/icing/pull_wordsScript.sml b/icing/pull_wordsScript.sml index 37c3236f2d..58d57a2988 100644 --- a/icing/pull_wordsScript.sml +++ b/icing/pull_wordsScript.sml @@ -1286,6 +1286,7 @@ Theorem do_app_thm: f1 = f2 ∧ res1_rel v1 v2 ∧ LIST_REL ref_rel r1 r2) (do_app (refs1,ffi) op a1) (do_app (refs2,ffi) op a2) Proof + cheat (* Cases_on ‘op’ >> gs[Once do_app_def, OPTREL_def] >- trivial_tac >- trivial_tac @@ -1421,7 +1422,7 @@ Proof >- trivial_tac >- (mem_tac >> rveq >> irule EVERY2_LUPDATE_same >> gs[]) >- (mem_tac >> rveq >> irule EVERY2_LUPDATE_same >> gs[]) - >> fp_tac >> simp[nat_to_v_def] + >> fp_tac >> simp[nat_to_v_def] *) QED diff --git a/icing/pureExpsScript.sml b/icing/pureExpsScript.sml index a1493b9411..3542b98e6c 100644 --- a/icing/pureExpsScript.sml +++ b/icing/pureExpsScript.sml @@ -32,6 +32,7 @@ Definition isPureOp_def: | CopyAw8Str => F | Eval => F | FFI _ => F + | ThunkOp _ => F | Opassign => F | Opapp => F | Opderef => F diff --git a/icing/source_to_source2ProofsScript.sml b/icing/source_to_source2ProofsScript.sml index 370d8fac49..df9bd29c33 100644 --- a/icing/source_to_source2ProofsScript.sml +++ b/icing/source_to_source2ProofsScript.sml @@ -1219,6 +1219,7 @@ Theorem perform_rewrites_correct: (st2 with fp_state := st2.fp_state with <| rws := st2.fp_state.rws ++ rws; opts := fpOptR; choices := choicesR |>, Rval r) Proof + cheat (* ho_match_mp_tac perform_rewrites_ind \\ rpt strip_tac \\ fs[perform_rewrites_def] \\ TRY (no_change_tac \\ NO_TAC) >- ( @@ -1531,7 +1532,7 @@ Proof \\ impl_tac >- gs[] \\ strip_tac \\ simp[evaluate_def] \\ qexists_tac ‘fpOpt’ \\ qexists_tac ‘choices’ - \\ gs[semState_comp_eq, fpState_component_equality] + \\ gs[semState_comp_eq, fpState_component_equality] *) QED Theorem is_rewriteFPexp_correct_lift_perform_rewrites: @@ -2433,6 +2434,7 @@ Theorem do_app_v_sim: LIST_REL (sv_rel v_sim1) sv1 sv2 /\ (isPureOp op ==> sv1 = sv2) /\ noopt_sim (list_result r1) (list_result r2) Proof + cheat (* rw[v_sim_LIST_REL] \\ TOP_CASE_TAC >- ( @@ -2563,7 +2565,7 @@ Proof \\ irule list_to_v_v_sim1 \\ fs[v_sim_LIST_REL] \\ irule LIST_REL_APPEND_suff - \\ fs[] + \\ fs[] *) QED Theorem build_conv_v_sim: @@ -2680,6 +2682,7 @@ Theorem no_optimisations_backwards_sim: (! e. ^P0 e) /\ (! l. ^P1 l) /\ (! p. ^P2 p) /\ (! l. ^P3 l) /\ (! p. ^P4 p) /\ (! p. ^P5 p) /\ (! l. ^P6 l) Proof + cheat (* irule ind_thm \\ rpt strip_tac \\ fs[] \\ rpt strip_tac \\ (qpat_x_assum ‘evaluate _ _ _ = _’ mp_tac @@ -3001,7 +3004,7 @@ Proof \\ first_assum (mp_then Any strip_assume_tac (CONJUNCT1 $ CONJUNCT2 evaluate_fp_opts_inv)) \\ first_x_assum (first_x_assum o mp_then Any (qspecl_then[`choices`,`fpScope`,`env2`]mp_tac)) \\ fs[isPureExp_def] ) - >- (rpt strip_tac \\ fs[evaluate_def,semState_comp_eq, fpState_component_equality] \\ rw[]) + >- (rpt strip_tac \\ fs[evaluate_def,semState_comp_eq, fpState_component_equality] \\ rw[]) *) QED end; From 24ce1b89a361e3177669392b1f657b7bda385009 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Mon, 30 Dec 2024 00:02:57 +0200 Subject: [PATCH 008/112] Updated itree semantics for thunks --- semantics/alt_semantics/itree_semanticsScript.sml | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/semantics/alt_semantics/itree_semanticsScript.sml b/semantics/alt_semantics/itree_semanticsScript.sml index ef7256fad3..ee70b679b7 100644 --- a/semantics/alt_semantics/itree_semanticsScript.sml +++ b/semantics/alt_semantics/itree_semanticsScript.sml @@ -14,6 +14,19 @@ Datatype: app_result = Rval v | Rraise v End +Definition thunk_op_def: + thunk_op (s: v store_v list) th_op vs = + case (th_op,vs) of + | (AllocThunk b, [v]) => + (let (s',n) = store_alloc (Thunk b v) s in + SOME (s', Rval (Loc F n))) + | (UpdateThunk b, [Loc _ lnum; v]) => + (case store_assign lnum (Thunk b v) s of + | SOME s' => SOME (s', Rval (Conv NONE [])) + | NONE => NONE) + | _ => NONE +End + Definition do_app_def: do_app s op vs = case (op, vs) of (ListAppend, [x1; x2]) => ( @@ -372,6 +385,7 @@ Definition do_app_def: Rval (Conv NONE [nat_to_v gen; nat_to_v id])) | (Env_id, [Conv NONE [gen; id]]) => SOME (s, Rval (Conv NONE [gen; id])) + | (ThunkOp th_op, vs) => thunk_op s th_op vs | _ => NONE End From fbb707303e47aeade246a73cbc752b4f77dd577f Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Tue, 7 Jan 2025 15:57:30 +0200 Subject: [PATCH 009/112] Added force semantics to itree semantics --- .../alt_semantics/itree_semanticsScript.sml | 21 ++++++++++++++++++ .../proofs/itree_semanticsPropsScript.sml | 22 ++++++++++++++----- 2 files changed, 38 insertions(+), 5 deletions(-) diff --git a/semantics/alt_semantics/itree_semanticsScript.sml b/semantics/alt_semantics/itree_semanticsScript.sml index ee70b679b7..f612288d83 100644 --- a/semantics/alt_semantics/itree_semanticsScript.sml +++ b/semantics/alt_semantics/itree_semanticsScript.sml @@ -396,6 +396,7 @@ Datatype: ctxt_frame = Craise | Chandle ((pat # exp) list) | Capp op (v list) (exp list) + | Cforce num | Clog lop exp | Cif exp exp | Cmat_check ((pat # exp) list) v @@ -449,6 +450,10 @@ Definition do_fprw_def: | (_, _) => NONE End +Definition AppUnit_def: + AppUnit e = App Opapp [e; Con NONE []] +End + Definition application_def: application op env s fp vs c : estep_result = case getOpClass op of @@ -487,6 +492,18 @@ Definition application_def: | SOME (s', Rval v) => return env s' fp v c | NONE => Etype_error (fix_fp_state c fp)) else Etype_error (fix_fp_state c (shift_fp_state fp)) + | Force => + (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 "pure_f" f env.v) s fp + (AppUnit (Var $ Short "pure_f")) (Cforce n) c + | _ => + Etype_error (fix_fp_state c fp)) + | _ => Etype_error (fix_fp_state c fp)) | _ => case op of | FFI n => ( @@ -513,6 +530,10 @@ Definition continue_def: continue s fp v ((Chandle pes, env)::c) = return env s fp v c ∧ continue s fp v ((Capp op vs [], env) :: c) = application op env s fp (v::vs) c ∧ continue s fp v ((Capp op vs (e::es), env) :: c) = push env s fp e (Capp op (v::vs) es) c ∧ + continue s fp v ((Cforce n, env) :: c) = ( + case store_assign n (Thunk F v) s of + SOME s' => return env s' fp v c + | NONE => Etype_error (fix_fp_state c fp)) ∧ continue s fp v ((Clog l e, env) :: c) = ( case do_log l v e of SOME (Exp e) => Estep (env, s, fp, Exp e, c) diff --git a/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml b/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml index 5e05277daf..01d3fc7dbf 100644 --- a/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml +++ b/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml @@ -574,22 +574,34 @@ Theorem application_thm: | SOME (s', Rval v) => return env s' fp v c | NONE => Etype_error (fix_fp_state c fp)) else Etype_error (fix_fp_state c (shift_fp_state fp)) + | Force => + (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 "pure_f" f env.v) s fp + (AppUnit (Var $ Short "pure_f")) (Cforce n) c + | _ => + Etype_error (fix_fp_state c fp)) + | _ => Etype_error (fix_fp_state c fp)) | _ => case do_app s op vs of | NONE => Etype_error (fix_fp_state c fp) | SOME (v1,Rval v') => return env v1 fp v' c | SOME (v1,Rraise v) => Estep (env,v1,fp,Exn v,c)) Proof - cheat (* - rpt strip_tac >> Cases_on ‘getOpClass op’ >> gs[] >> + cheat (* works in interactive, doesn't work with Holmake *) + (*rpt strip_tac >> Cases_on ‘getOpClass op’ >> gs[] >> TOP_CASE_TAC >> gs[application_def] >- ( Cases_on ‘op’ >> gs[application_def] >> every_case_tac >> gs[do_app_def] >> - every_case_tac >> gs[]) - >- ( + every_case_tac >> gs[]) >> Cases_on ‘op’ >> gs[application_def] >> every_case_tac >> gs[do_app_def] >> pop_assum $ mp_tac >> - rpt (TOP_CASE_TAC >> gvs[SF itree_ss]) >> gs[store_alloc_def]) *) + rpt (TOP_CASE_TAC >> gvs[SF itree_ss]) >> gs[store_alloc_def] >> + rpt (FULL_CASE_TAC >> gvs[thunk_op_def, store_alloc_def, store_assign_def])*) QED Theorem application_FFI_results: From 497fe3a7d1e571841cb910aeafdc4441f84549ce Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Fri, 10 Jan 2025 04:50:45 +0200 Subject: [PATCH 010/112] Changed force semantics to apply function directly instead of going through singleton env --- semantics/alt_semantics/itree_semanticsScript.sml | 10 ++++------ .../proofs/itree_semanticsPropsScript.sml | 3 +-- 2 files changed, 5 insertions(+), 8 deletions(-) diff --git a/semantics/alt_semantics/itree_semanticsScript.sml b/semantics/alt_semantics/itree_semanticsScript.sml index f612288d83..b091e048bb 100644 --- a/semantics/alt_semantics/itree_semanticsScript.sml +++ b/semantics/alt_semantics/itree_semanticsScript.sml @@ -450,10 +450,6 @@ Definition do_fprw_def: | (_, _) => NONE End -Definition AppUnit_def: - AppUnit e = App Opapp [e; Con NONE []] -End - Definition application_def: application op env s fp vs c : estep_result = case getOpClass op of @@ -499,8 +495,7 @@ Definition application_def: SOME (Thunk F v) => return env s fp v c | SOME (Thunk T f) => - push (env with v := nsBind "pure_f" f env.v) s fp - (AppUnit (Var $ Short "pure_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)) @@ -522,6 +517,9 @@ Definition application_def: SOME (s', Rraise v) => Estep (env, s, fp, Exn v,c) | SOME (s', Rval v) => return env s' fp v c | NONE => Etype_error (fix_fp_state c fp) ) +Termination + WF_REL_TAC ‘measure (λ(x,_). if x = ThunkOp ForceThunk then 1 else 0)’ >> + rw[] >> Cases_on ‘op’ >> gvs[] End Definition continue_def: diff --git a/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml b/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml index 01d3fc7dbf..59f7a3ba1c 100644 --- a/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml +++ b/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml @@ -581,8 +581,7 @@ Theorem application_thm: SOME (Thunk F v) => return env s fp v c | SOME (Thunk T f) => - push (env with v := nsBind "pure_f" f env.v) s fp - (AppUnit (Var $ Short "pure_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)) From 11d359764db23f68ec35e6d3e365d2239ebd7553 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Sun, 12 Jan 2025 16:41:11 +0200 Subject: [PATCH 011/112] Removed a cheat --- .../proofs/itree_semanticsPropsScript.sml | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml b/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml index 59f7a3ba1c..a1a1ab6a88 100644 --- a/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml +++ b/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml @@ -591,16 +591,17 @@ Theorem application_thm: | SOME (v1,Rval v') => return env v1 fp v' c | SOME (v1,Rraise v) => Estep (env,v1,fp,Exn v,c)) Proof - cheat (* works in interactive, doesn't work with Holmake *) - (*rpt strip_tac >> Cases_on ‘getOpClass op’ >> gs[] >> + rpt strip_tac >> Cases_on ‘getOpClass op’ >> gs[] >> TOP_CASE_TAC >> gs[application_def] >- ( - Cases_on ‘op’ >> gs[application_def] >> every_case_tac >> gs[do_app_def] >> + Cases_on ‘op’ >> gs[application_def] >> every_case_tac >> + gs[itree_semanticsTheory.do_app_def] >> every_case_tac >> gs[]) >> - Cases_on ‘op’ >> gs[application_def] >> every_case_tac >> gs[do_app_def] >> + Cases_on ‘op’ >> gs[application_def] >> every_case_tac >> + gs[itree_semanticsTheory.do_app_def] >> pop_assum $ mp_tac >> rpt (TOP_CASE_TAC >> gvs[SF itree_ss]) >> gs[store_alloc_def] >> - rpt (FULL_CASE_TAC >> gvs[thunk_op_def, store_alloc_def, store_assign_def])*) + rpt (FULL_CASE_TAC >> gvs[thunk_op_def, store_alloc_def, store_assign_def]) QED Theorem application_FFI_results: From 56926cc766cba4885b77ab848ea2b2f225d84e6e Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Thu, 24 Apr 2025 12:26:49 +0200 Subject: [PATCH 012/112] Minor tweak --- semantics/semanticPrimitivesScript.sml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/semantics/semanticPrimitivesScript.sml b/semantics/semanticPrimitivesScript.sml index c673f57f6c..8aee54f645 100644 --- a/semantics/semanticPrimitivesScript.sml +++ b/semantics/semanticPrimitivesScript.sml @@ -197,7 +197,7 @@ Datatype: (* An array of values *) | Varray ('a list) (* Thunk *) - | Thunk bool 'a + | Thunk bool 'a (* T means evaluated *) End Definition store_v_same_type_def: @@ -206,7 +206,7 @@ Definition store_v_same_type_def: | (Refv _, Refv _ ) => T | (W8array _, W8array _) => T | (Varray _, Varray _ ) => T - | (Thunk T _, Thunk _ _) => T (* the thunk being updated must have T set *) + | (Thunk F _, Thunk _ _) => T (* the thunk being updated must have F set *) | _ => F End From 5ff8af82d9f90c26e94b922e3644c711aed88016 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Thu, 24 Apr 2025 12:40:40 +0200 Subject: [PATCH 013/112] Speed up a slow proof --- semantics/lexer_funScript.sml | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/semantics/lexer_funScript.sml b/semantics/lexer_funScript.sml index 9c273d4e9f..78a45f1fef 100644 --- a/semantics/lexer_funScript.sml +++ b/semantics/lexer_funScript.sml @@ -135,14 +135,15 @@ Proof \\ REPEAT STRIP_TAC \\ POP_ASSUM MP_TAC \\ ONCE_REWRITE_TAC [read_string_def] \\ Cases_on `s` \\ SIMP_TAC (srw_ss()) [] - \\ SRW_TAC [] [LENGTH] \\ RES_TAC \\ TRY DECIDE_TAC - \\ SRW_TAC [] [LENGTH] \\ Cases_on `t'` - \\ FULL_SIMP_TAC (srw_ss()) [] \\ CCONTR_TAC - \\ Q.PAT_X_ASSUM `(x1, l', x2) = xxx` MP_TAC - \\ SIMP_TAC std_ss [] \\ SRW_TAC [] [] - \\ REPEAT STRIP_TAC \\ FULL_SIMP_TAC std_ss [] - \\ RES_TAC \\ TRY DECIDE_TAC \\ CCONTR_TAC - \\ gvs[AllCaseEqs()] \\ drule read_char_as_3digits_reduces >> simp[] + \\ IF_CASES_TAC \\ gvs [SF SFY_ss,ADD1] + \\ IF_CASES_TAC \\ gvs [SF SFY_ss,ADD1] + \\ IF_CASES_TAC \\ gvs [SF SFY_ss,ADD1] + \\ CASE_TAC \\ gvs [] + \\ rpt (IF_CASES_TAC \\ gvs [SF SFY_ss,ADD1] + >- (rpt strip_tac \\ res_tac \\ gvs [])) + \\ IF_CASES_TAC \\ gvs [] + \\ gvs [AllCaseEqs()] \\ rw [] \\ gvs [] + \\ drule read_char_as_3digits_reduces \\ simp[] QED Definition skip_comment_def: From 270490bcc6fcf81c10361fdc2cd750058f84df46 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Mon, 28 Apr 2025 23:50:33 +0300 Subject: [PATCH 014/112] Merged master, fixed bugs introduced by swapping the meaning of the boolean flag of thunks, and updated HOL version. `compilerProof` doesn't build due to `check_thm` failing with an obscure error message, whereas the proof itself works fine. Probably has to do with changes in HOL and needs fixing. HOL commit 48a676cadda70ad7fc2f6c7b17ecd434f84db113. --- compiler/backend/flat_to_closScript.sml | 14 ++++++++++---- semantics/alt_semantics/itree_semanticsScript.sml | 6 +++--- .../proofs/itree_semanticsPropsScript.sml | 4 ++-- translator/ml_optimiseScript.sml | 2 +- 4 files changed, 16 insertions(+), 10 deletions(-) diff --git a/compiler/backend/flat_to_closScript.sml b/compiler/backend/flat_to_closScript.sml index e905a7b3ff..ea439a3d24 100644 --- a/compiler/backend/flat_to_closScript.sml +++ b/compiler/backend/flat_to_closScript.sml @@ -192,12 +192,18 @@ Definition compile_op_def: | ThunkOp t => (dtcase t of | AllocThunk b => - Let None xs (Op None Ref [Op None (Cons (if b then 1 else 0)) []; Var None 0]) + Let None xs (Op None (MemOp Ref) [ + Op None (BlockOp (Cons (if b then 1 else 0))) []; + Var None 0]) | UpdateThunk b => Let None xs (Let None - [Op None Update [Var None 0; Op None (Const 0) []; Op None (Cons (if b then 1 else 0)) []]; - Op None Update [Var None 0; Op None (Const 1) []; Var None 1]] - (Var None 0)) + [Op None (MemOp Update) [ + Var None 0; Op None (IntOp (Const 0)) []; + Op None (BlockOp (Cons (if b then 1 else 0))) []]; + Op None (MemOp Update) [ + Var None 0; Op None (IntOp (Const 1)) []; + Var None 1]] + (Var None 0)) | ForceThunk => Let None xs (Var None 0)) | _ => Let None xs (Var None 0) diff --git a/semantics/alt_semantics/itree_semanticsScript.sml b/semantics/alt_semantics/itree_semanticsScript.sml index b091e048bb..85b976b80b 100644 --- a/semantics/alt_semantics/itree_semanticsScript.sml +++ b/semantics/alt_semantics/itree_semanticsScript.sml @@ -492,9 +492,9 @@ Definition application_def: (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)) @@ -529,7 +529,7 @@ Definition continue_def: continue s fp v ((Capp op vs [], env) :: c) = application op env s fp (v::vs) c ∧ continue s fp v ((Capp op vs (e::es), env) :: c) = push env s fp e (Capp op (v::vs) es) c ∧ continue s fp v ((Cforce n, env) :: c) = ( - case store_assign n (Thunk F v) s of + case store_assign n (Thunk T v) s of SOME s' => return env s' fp v c | NONE => Etype_error (fix_fp_state c fp)) ∧ continue s fp v ((Clog l e, env) :: c) = ( diff --git a/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml b/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml index a1a1ab6a88..5aff547973 100644 --- a/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml +++ b/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml @@ -578,9 +578,9 @@ Theorem application_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)) diff --git a/translator/ml_optimiseScript.sml b/translator/ml_optimiseScript.sml index dad759b100..2773ccd6d1 100644 --- a/translator/ml_optimiseScript.sml +++ b/translator/ml_optimiseScript.sml @@ -177,7 +177,7 @@ Proof \\ first_x_assum drule \\ simp [] \\ strip_tac \\ asm_exists_tac \\ fs []) THEN1 (* App Eval *) - (fs [evaluateTheory.do_eval_res_def (*, Q.ISPEC `(_, _)` EQ_SYM_EQ *)] + ( fs [evaluateTheory.do_eval_res_def] \\ fs [list_case_eq,option_case_eq,bool_case_eq,pair_case_eq,result_case_eq] \\ rveq \\ fs [PULL_EXISTS] From 2ef8c9fe897bd690a4c42e65b4c19b3bd461e58a Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Tue, 29 Apr 2025 13:52:03 +0300 Subject: [PATCH 015/112] Introduced `thunk_mode` datatype for thunks to replace the bool flag. `compilerProof` fails due to cheats introduced previously HOL commit 48a676cadda70ad7fc2f6c7b17ecd434f84db113 --- compiler/backend/flat_to_closScript.sml | 13 +++++-- compiler/backend/presLangScript.sml | 18 +++++++-- .../proofs/flat_to_closProofScript.sml | 10 ++++- .../backend/semantics/flatPropsScript.sml | 2 +- compiler/backend/semantics/flatSemScript.sml | 14 +++---- compiler/parsing/fromSexpScript.sml | 37 +++++++++++-------- .../alt_semantics/itree_semanticsScript.sml | 14 +++---- .../proofs/itree_semanticsPropsScript.sml | 4 +- semantics/astScript.sml | 8 +++- semantics/evaluateScript.sml | 6 +-- .../proofs/semanticPrimitivesPropsScript.sml | 8 ++-- semantics/semanticPrimitivesScript.sml | 12 +++--- 12 files changed, 89 insertions(+), 57 deletions(-) diff --git a/compiler/backend/flat_to_closScript.sml b/compiler/backend/flat_to_closScript.sml index ea439a3d24..9994cd072e 100644 --- a/compiler/backend/flat_to_closScript.sml +++ b/compiler/backend/flat_to_closScript.sml @@ -96,6 +96,11 @@ Definition CopyByteAw8_def: CopyByteAw8 t = ^checkF End +Definition thunk_mode_to_digit_def[simp]: + thunk_mode_to_digit NotEvaluated : num = 0 ∧ + thunk_mode_to_digit Evaluated = 1 +End + Definition compile_op_def: compile_op t op xs = dtcase op of @@ -191,15 +196,15 @@ Definition compile_op_def: | Eval => Op t Install xs (* if need to flip: Let t xs (Op t Install [Var t 1; Var t 0]) *) | ThunkOp t => (dtcase t of - | AllocThunk b => + | AllocThunk m => Let None xs (Op None (MemOp Ref) [ - Op None (BlockOp (Cons (if b then 1 else 0))) []; + Op None (BlockOp (Cons (thunk_mode_to_digit m))) []; Var None 0]) - | UpdateThunk b => + | UpdateThunk m => Let None xs (Let None [Op None (MemOp Update) [ Var None 0; Op None (IntOp (Const 0)) []; - Op None (BlockOp (Cons (if b then 1 else 0))) []]; + Op None (BlockOp (Cons (thunk_mode_to_digit m))) []]; Op None (MemOp Update) [ Var None 0; Op None (IntOp (Const 1)) []; Var None 1]] diff --git a/compiler/backend/presLangScript.sml b/compiler/backend/presLangScript.sml index 2046873b36..efac8a1529 100644 --- a/compiler/backend/presLangScript.sml +++ b/compiler/backend/presLangScript.sml @@ -188,6 +188,12 @@ Definition shift_to_display_def: (shift_to_display Ror = empty_item (strlit "Ror")) End +Definition thunk_mode_to_display_def: + (thunk_mode_to_display Evaluated = empty_item (strlit "Evaluated")) + /\ + (thunk_mode_to_display NotEvaluated = empty_item (strlit "NotEvaluated")) +End + Definition op_to_display_def: op_to_display (p:ast$op) = case p of @@ -254,8 +260,10 @@ Definition op_to_display_def: | Env_id => empty_item (strlit "Eval") | ThunkOp t => (case t of - | AllocThunk b => Item NONE (strlit "AllocThunk") [bool_to_display b] - | UpdateThunk b => Item NONE (strlit "UpdateThunk") [bool_to_display b] + | AllocThunk m => + Item NONE (strlit "AllocThunk") [thunk_mode_to_display m] + | UpdateThunk m => + Item NONE (strlit "UpdateThunk") [thunk_mode_to_display m] | ForceThunk => empty_item (strlit "ForceThunk")) End @@ -486,8 +494,10 @@ Definition flat_op_to_display_def: | Eval => empty_item (strlit "Eval") | ThunkOp t => (case t of - | AllocThunk b => Item NONE (strlit "AllocThunk") [bool_to_display b] - | UpdateThunk b => Item NONE (strlit "UpdateThunk") [bool_to_display b] + | AllocThunk m => + Item NONE (strlit "AllocThunk") [thunk_mode_to_display m] + | UpdateThunk m => + Item NONE (strlit "UpdateThunk") [thunk_mode_to_display m] | ForceThunk => empty_item (strlit "ForceThunk")) | GlobalVarAlloc n => item_with_num (strlit "GlobalVarAlloc") n | GlobalVarInit n => item_with_num (strlit "GlobalVarInit") n diff --git a/compiler/backend/proofs/flat_to_closProofScript.sml b/compiler/backend/proofs/flat_to_closProofScript.sml index b7182558cc..2e3e90d0d3 100644 --- a/compiler/backend/proofs/flat_to_closProofScript.sml +++ b/compiler/backend/proofs/flat_to_closProofScript.sml @@ -76,12 +76,20 @@ Definition opt_rel_def[simp]: opt_rel f _ _ = F End +Definition thunk_mode_to_digit_def[simp]: + thunk_mode_to_digit NotEvaluated = 0 /\ + thunk_mode_to_digit Evaluated = 1 +End + Definition store_rel_def: store_rel refs t_refs = !i. if LENGTH refs <= i then FLOOKUP t_refs i = NONE else case EL i refs of | Refv v => (?x. FLOOKUP t_refs i = SOME (ValueArray [x]) /\ v_rel v x) - | Thunk b v => (?x. FLOOKUP t_refs i = SOME (ValueArray [Block (if b then 1 else 0) []; x]) /\ v_rel v x) + | Thunk m v => + (?x. FLOOKUP t_refs i = SOME (ValueArray [ + Block (thunk_mode_to_digit m) []; x]) /\ + v_rel v x) | Varray vs => (?xs. FLOOKUP t_refs i = SOME (ValueArray xs) /\ LIST_REL v_rel vs xs) | W8array bs => FLOOKUP t_refs i = SOME (ByteArray bs) diff --git a/compiler/backend/semantics/flatPropsScript.sml b/compiler/backend/semantics/flatPropsScript.sml index 09832ef62d..a62789c50b 100644 --- a/compiler/backend/semantics/flatPropsScript.sml +++ b/compiler/backend/semantics/flatPropsScript.sml @@ -1384,7 +1384,7 @@ Theorem flat_evaluate_def = flat_evaluate_def Definition store_v_vs_def[simp]: store_v_vs (Varray vs) = vs /\ store_v_vs (Refv v) = [v] /\ - store_v_vs (Thunk b v) = [v] /\ + store_v_vs (Thunk m v) = [v] /\ store_v_vs (W8array xs) = [] End diff --git a/compiler/backend/semantics/flatSemScript.sml b/compiler/backend/semantics/flatSemScript.sml index ea663b8a9d..45eec798b7 100644 --- a/compiler/backend/semantics/flatSemScript.sml +++ b/compiler/backend/semantics/flatSemScript.sml @@ -536,11 +536,11 @@ Definition do_app_def: SOME (s, Rval v1) | (ThunkOp th_op, vs) => (case (th_op,vs) of - | (AllocThunk b, [v]) => - (let (r,n) = store_alloc (Thunk b v) s.refs in + | (AllocThunk m, [v]) => + (let (r,n) = store_alloc (Thunk m v) s.refs in SOME (s with refs := r, Rval (Loc F n))) - | (UpdateThunk b, [Loc _ lnum; v]) => - (case store_assign lnum (Thunk b v) s.refs of + | (UpdateThunk m, [Loc _ lnum; v]) => + (case store_assign lnum (Thunk m v) s.refs of | SOME r => SOME (s with refs := r, Rval (Conv NONE [])) | NONE => NONE) | _ => NONE) @@ -689,14 +689,14 @@ End Definition dest_thunk_def: dest_thunk [Loc _ n] st = (case store_lookup n st of - | SOME (Thunk T v) => SOME (INL v) - | SOME (Thunk F v) => SOME (INR v) + | SOME (Thunk Evaluated v) => SOME (INL v) + | SOME (Thunk NotEvaluated v) => SOME (INR v) | _ => NONE) ∧ dest_thunk vs st = NONE End Definition update_thunk_def: - update_thunk [Loc _ n] st [v] = store_assign n (Thunk T v) st ∧ + update_thunk [Loc _ n] st [v] = store_assign n (Thunk Evaluated v) st ∧ update_thunk _ st _ = NONE End diff --git a/compiler/parsing/fromSexpScript.sml b/compiler/parsing/fromSexpScript.sml index 275c147c8e..9d7174f42d 100644 --- a/compiler/parsing/fromSexpScript.sml +++ b/compiler/parsing/fromSexpScript.sml @@ -649,13 +649,16 @@ Proof rw[FUN_EQ_THM,sexppat_alt_intro] QED -Definition decode_bool_def: - decode_bool s = if s = "T" then SOME T else - if s = "F" then SOME F else NONE +Definition decode_thunk_mode_def: + decode_thunk_mode s = + if s = "Evaluated" then SOME Evaluated + else if s = "NotEvaluated" then SOME NotEvaluated + else NONE End -Definition encode_bool_def: - encode_bool b = if b then "T" else "F" +Definition encode_thunk_mode_def: + encode_thunk_mode Evaluated = "Evaluated" ∧ + encode_thunk_mode NotEvaluated = "NotEvaluated" End Definition sexpop_def: @@ -757,11 +760,11 @@ Definition sexpop_def: if s = "FFI" then OPTION_MAP FFI (decode_control s') else NONE ) ∧ (sexpop (SX_CONS (SX_SYM s) (SX_SYM t)) = - case decode_bool t of + case decode_thunk_mode t of | NONE => NONE - | SOME b => - if s = "AllocThunk" then SOME (ThunkOp (AllocThunk b)) else - if s = "UpdateThunk" then SOME (ThunkOp (UpdateThunk b)) else NONE + | SOME m => + if s = "AllocThunk" then SOME (ThunkOp (AllocThunk m)) else + if s = "UpdateThunk" then SOME (ThunkOp (UpdateThunk m)) else NONE ) ∧ (sexpop (SX_CONS (SX_SYM s) (SX_NUM n)) = if s = "Shift8Lsl" then SOME (Shift W8 Lsl n) else @@ -1425,10 +1428,10 @@ Definition opsexp_def: (opsexp Env_id = SX_SYM "Envid") ∧ (opsexp (FFI s) = SX_CONS (SX_SYM "FFI") (SEXSTR s)) ∧ (opsexp (ThunkOp ForceThunk) = SX_SYM "ForceThunk") ∧ - (opsexp (ThunkOp (AllocThunk b)) = - SX_CONS (SX_SYM "AllocThunk") (SX_SYM (encode_bool b))) ∧ - (opsexp (ThunkOp (UpdateThunk b)) = - SX_CONS (SX_SYM "UpdateThunk") (SX_SYM (encode_bool b))) + (opsexp (ThunkOp (AllocThunk m)) = + SX_CONS (SX_SYM "AllocThunk") (SX_SYM (encode_thunk_mode m))) ∧ + (opsexp (ThunkOp (UpdateThunk m)) = + SX_CONS (SX_SYM "UpdateThunk") (SX_SYM (encode_thunk_mode m))) End Theorem sexpop_opsexp[simp]: @@ -1436,8 +1439,9 @@ Theorem sexpop_opsexp[simp]: Proof Cases_on ‘∃t. op = ThunkOp t’ >- (gvs [] \\ Cases_on ‘t’ - \\ gvs [sexpop_def,opsexp_def,encode_bool_def,decode_bool_def] - \\ rw [] \\ gvs [AllCaseEqs()]) >> + \\ gvs [sexpop_def,opsexp_def] + \\ rw [] \\ gvs [AllCaseEqs()] + \\ Cases_on ‘t'’ \\ gvs [encode_thunk_mode_def,decode_thunk_mode_def]) >> Cases_on`op`>>fs []>>rw[sexpop_def,opsexp_def] >> TRY(MAP_FIRST rename1 [ ‘Opn c1’, ‘Opb c1’, ‘Opw c2 c1’, ‘Chopb c1’, ‘Shift c1 c2 _’, @@ -1992,7 +1996,7 @@ Proof \\ Cases_on ‘s1’ \\ gvs[sexpop_def] \\ Cases_on ‘s2’ \\ gvs[sexpop_def, AllCaseEqs(), opsexp_def, encode_decode_control] - \\ gvs [encode_bool_def,decode_bool_def,AllCaseEqs()] + \\ gvs [encode_thunk_mode_def,decode_thunk_mode_def,AllCaseEqs()] QED Theorem lopsexp_sexplop: @@ -2183,6 +2187,7 @@ Proof \\ TRY(Cases_on`f`) \\ simp[opsexp_def] \\ TRY(Cases_on`r`) \\ simp[opsexp_def] \\ TRY(Cases_on`t`) \\ simp[opsexp_def] + \\ TRY(Cases_on`t'`) \\ simp[encode_thunk_mode_def] \\ TRY(Cases_on`b`) \\ simp[opsexp_def] \\ EVAL_TAC QED diff --git a/semantics/alt_semantics/itree_semanticsScript.sml b/semantics/alt_semantics/itree_semanticsScript.sml index 85b976b80b..05e614e1d0 100644 --- a/semantics/alt_semantics/itree_semanticsScript.sml +++ b/semantics/alt_semantics/itree_semanticsScript.sml @@ -17,11 +17,11 @@ End Definition thunk_op_def: thunk_op (s: v store_v list) th_op vs = case (th_op,vs) of - | (AllocThunk b, [v]) => - (let (s',n) = store_alloc (Thunk b v) s in + | (AllocThunk m, [v]) => + (let (s',n) = store_alloc (Thunk m v) s in SOME (s', Rval (Loc F n))) - | (UpdateThunk b, [Loc _ lnum; v]) => - (case store_assign lnum (Thunk b v) s of + | (UpdateThunk m, [Loc _ lnum; v]) => + (case store_assign lnum (Thunk m v) s of | SOME s' => SOME (s', Rval (Conv NONE [])) | NONE => NONE) | _ => NONE @@ -492,9 +492,9 @@ Definition application_def: (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)) @@ -529,7 +529,7 @@ Definition continue_def: continue s fp v ((Capp op vs [], env) :: c) = application op env s fp (v::vs) c ∧ continue s fp v ((Capp op vs (e::es), env) :: c) = push env s fp e (Capp op (v::vs) es) c ∧ continue s fp v ((Cforce n, env) :: c) = ( - case store_assign n (Thunk T v) s of + case store_assign n (Thunk Evaluated v) s of SOME s' => return env s' fp v c | NONE => Etype_error (fix_fp_state c fp)) ∧ continue s fp v ((Clog l e, env) :: c) = ( diff --git a/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml b/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml index 5aff547973..a4efe8f960 100644 --- a/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml +++ b/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml @@ -578,9 +578,9 @@ Theorem application_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)) diff --git a/semantics/astScript.sml b/semantics/astScript.sml index a9630ff262..9c10f25836 100644 --- a/semantics/astScript.sml +++ b/semantics/astScript.sml @@ -54,10 +54,14 @@ Datatype: word_size = W8 | W64 End +Datatype: + thunk_mode = Evaluated | NotEvaluated +End + Datatype: thunk_op = - AllocThunk bool - | UpdateThunk bool + AllocThunk thunk_mode + | UpdateThunk thunk_mode | ForceThunk End diff --git a/semantics/evaluateScript.sml b/semantics/evaluateScript.sml index 2e30124827..887b516001 100644 --- a/semantics/evaluateScript.sml +++ b/semantics/evaluateScript.sml @@ -58,14 +58,14 @@ End Definition dest_thunk_def: dest_thunk [Loc _ n] st = (case store_lookup n st of - | SOME (Thunk T v) => SOME (INL v) - | SOME (Thunk F v) => SOME (INR v) + | SOME (Thunk Evaluated v) => SOME (INL v) + | SOME (Thunk NotEvaluated v) => SOME (INR v) | _ => NONE) ∧ dest_thunk vs st = NONE End Definition update_thunk_def: - update_thunk [Loc _ n] st [v] = store_assign n (Thunk T v) st ∧ + update_thunk [Loc _ n] st [v] = store_assign n (Thunk Evaluated v) st ∧ update_thunk _ st _ = NONE End diff --git a/semantics/proofs/semanticPrimitivesPropsScript.sml b/semantics/proofs/semanticPrimitivesPropsScript.sml index 5826b0cbb4..c7283618b1 100644 --- a/semantics/proofs/semanticPrimitivesPropsScript.sml +++ b/semantics/proofs/semanticPrimitivesPropsScript.sml @@ -518,7 +518,7 @@ Definition map_sv_def: map_sv f (Refv v) = Refv (f v) ∧ map_sv _ (W8array w) = (W8array w) ∧ map_sv f (Varray vs) = (Varray (MAP f vs)) ∧ - map_sv f (Thunk b v) = (Thunk b (f v)) + map_sv f (Thunk m v) = (Thunk m (f v)) End val _ = export_rewrites["map_sv_def"] @@ -534,7 +534,7 @@ val _ = export_rewrites["dest_Refv_def","is_Refv_def"] Definition sv_every_def: sv_every P (Refv v) = P v ∧ sv_every P (Varray vs) = EVERY P vs ∧ - sv_every P (Thunk b v) = P v ∧ + sv_every P (Thunk m v) = P v ∧ sv_every P _ = T End val _ = export_rewrites["sv_every_def"] @@ -543,7 +543,7 @@ Definition sv_rel_def: sv_rel R (Refv v1) (Refv v2) = R v1 v2 ∧ sv_rel R (W8array w1) (W8array w2) = (w1 = w2) ∧ sv_rel R (Varray vs1) (Varray vs2) = LIST_REL R vs1 vs2 ∧ - sv_rel R (Thunk b1 v1) (Thunk b2 v2) = (b1 = b2 ∧ R v1 v2) ∧ + sv_rel R (Thunk m1 v1) (Thunk m2 v2) = (m1 = m2 ∧ R v1 v2) ∧ sv_rel R _ _ = F End val _ = export_rewrites["sv_rel_def"] @@ -568,7 +568,7 @@ Theorem sv_rel_cases: sv_rel R x y ⇔ (∃v1 v2. x = Refv v1 ∧ y = Refv v2 ∧ R v1 v2) ∨ (∃w. x = W8array w ∧ y = W8array w) ∨ - (∃b v1 v2. x = Thunk b v1 ∧ y = Thunk b v2 ∧ R v1 v2) ∨ + (∃m v1 v2. x = Thunk m v1 ∧ y = Thunk m v2 ∧ R v1 v2) ∨ (?vs1 vs2. x = Varray vs1 ∧ y = Varray vs2 ∧ LIST_REL R vs1 vs2) Proof Cases >> Cases >> simp[sv_rel_def,EQ_IMP_THM] >> metis_tac [] diff --git a/semantics/semanticPrimitivesScript.sml b/semantics/semanticPrimitivesScript.sml index 8aee54f645..d2e5bc845f 100644 --- a/semantics/semanticPrimitivesScript.sml +++ b/semantics/semanticPrimitivesScript.sml @@ -197,7 +197,7 @@ Datatype: (* An array of values *) | Varray ('a list) (* Thunk *) - | Thunk bool 'a (* T means evaluated *) + | Thunk thunk_mode 'a End Definition store_v_same_type_def: @@ -206,7 +206,7 @@ Definition store_v_same_type_def: | (Refv _, Refv _ ) => T | (W8array _, W8array _) => T | (Varray _, Varray _ ) => T - | (Thunk F _, Thunk _ _) => T (* the thunk being updated must have F set *) + | (Thunk NotEvaluated _, Thunk _ _) => T | _ => F End @@ -884,11 +884,11 @@ End Definition thunk_op_def: thunk_op (s: v store_v list, t: 'ffi ffi_state) th_op vs = case (th_op,vs) of - | (AllocThunk b, [v]) => - (let (s',n) = store_alloc (Thunk b v) s in + | (AllocThunk m, [v]) => + (let (s',n) = store_alloc (Thunk m v) s in SOME ((s',t), Rval (Loc F n))) - | (UpdateThunk b, [Loc _ lnum; v]) => - (case store_assign lnum (Thunk b v) s of + | (UpdateThunk m, [Loc _ lnum; v]) => + (case store_assign lnum (Thunk m v) s of | SOME s' => SOME ((s',t), Rval (Conv NONE [])) | NONE => NONE) | _ => NONE From 69329440e3d5579360532cc84c42c62fb921822f Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Sun, 4 May 2025 22:12:13 +0300 Subject: [PATCH 016/112] Added thunks to closLang Proved all cheats up to `clos_to_bvl`. HOL commit 48a676cadda70ad7fc2f6c7b17ecd434f84db113 --- compiler/backend/closLangScript.sml | 2 + compiler/backend/flat_to_closScript.sml | 18 +- .../backend/proofs/bvi_to_dataProofScript.sml | 8 +- .../backend/proofs/bvl_to_bviProofScript.sml | 18 +- .../proofs/clos_annotateProofScript.sml | 65 +++ .../backend/proofs/clos_callProofScript.sml | 351 +++++++++---- .../backend/proofs/clos_fvsProofScript.sml | 68 ++- .../backend/proofs/clos_interpProofScript.sml | 195 ++++++-- .../backend/proofs/clos_knownProofScript.sml | 466 ++++++++++++++++-- .../backend/proofs/clos_letopProofScript.sml | 69 ++- .../backend/proofs/clos_mtiProofScript.sml | 93 +++- .../backend/proofs/clos_numberProofScript.sml | 54 +- .../backend/proofs/clos_ticksProofScript.sml | 140 ++++-- .../backend/proofs/clos_to_bvlProofScript.sml | 7 +- .../backend/proofs/data_liveProofScript.sml | 3 +- .../proofs/data_to_wordProofScript.sml | 6 +- .../proofs/data_to_word_assignProofScript.sml | 3 +- .../backend/proofs/flat_elimProofScript.sml | 73 ++- .../proofs/flat_patternProofScript.sml | 70 ++- .../proofs/flat_to_closProofScript.sml | 110 ++++- .../backend/proofs/source_evalProofScript.sml | 141 +++++- .../proofs/source_to_flatProofScript.sml | 202 +++++++- .../backend/semantics/closPropsScript.sml | 88 +++- compiler/backend/semantics/closSemScript.sml | 58 ++- compiler/backend/semantics/flatSemScript.sml | 6 +- semantics/evaluateScript.sml | 6 +- semantics/proofs/evaluatePropsScript.sml | 61 ++- translator/ml_optimiseScript.sml | 13 +- 28 files changed, 2057 insertions(+), 337 deletions(-) diff --git a/compiler/backend/closLangScript.sml b/compiler/backend/closLangScript.sml index f22893ca67..5491aa23f3 100644 --- a/compiler/backend/closLangScript.sml +++ b/compiler/backend/closLangScript.sml @@ -117,6 +117,7 @@ Datatype: | GlobOp glob_op | MemOp mem_op | Install (* installs new code at runtime *) + | ThunkOp thunk_op End Datatype: @@ -180,6 +181,7 @@ Definition pure_op_def: | MemOp Ref => F | MemOp Update => F | Install => F + | ThunkOp _ => F | _ => T End diff --git a/compiler/backend/flat_to_closScript.sml b/compiler/backend/flat_to_closScript.sml index 9994cd072e..95294f8407 100644 --- a/compiler/backend/flat_to_closScript.sml +++ b/compiler/backend/flat_to_closScript.sml @@ -194,23 +194,7 @@ Definition compile_op_def: | Shift x1 x2 x3 => Op t (WordOp (WordShift x1 x2 x3)) xs | Opw x1 x2 => Op t (WordOp (WordOpw x1 x2)) xs | Eval => Op t Install xs (* if need to flip: Let t xs (Op t Install [Var t 1; Var t 0]) *) - | ThunkOp t => - (dtcase t of - | AllocThunk m => - Let None xs (Op None (MemOp Ref) [ - Op None (BlockOp (Cons (thunk_mode_to_digit m))) []; - Var None 0]) - | UpdateThunk m => - Let None xs (Let None - [Op None (MemOp Update) [ - Var None 0; Op None (IntOp (Const 0)) []; - Op None (BlockOp (Cons (thunk_mode_to_digit m))) []]; - Op None (MemOp Update) [ - Var None 0; Op None (IntOp (Const 1)) []; - Var None 1]] - (Var None 0)) - | ForceThunk => - Let None xs (Var None 0)) + | ThunkOp op => Op t (ThunkOp op) xs | _ => Let None xs (Var None 0) End diff --git a/compiler/backend/proofs/bvi_to_dataProofScript.sml b/compiler/backend/proofs/bvi_to_dataProofScript.sml index 9a1b575448..ed7c75bf1b 100644 --- a/compiler/backend/proofs/bvi_to_dataProofScript.sml +++ b/compiler/backend/proofs/bvi_to_dataProofScript.sml @@ -474,7 +474,8 @@ Proof QED fun cases_on_op q = Cases_on q >| - map (MAP_EVERY Cases_on) [[], [], [`i`], [`w`], [`b`], [`g`], [`m`], []]; + map (MAP_EVERY Cases_on) + [[`n`], [`s`], [`i`], [`w`], [`b`], [`g`], [`m`], [], [`t`]]; Theorem data_to_bvi_do_app: ∀op t r z res s1. @@ -544,10 +545,11 @@ Proof ,data_to_bvi_v_Unit ,data_to_bvi_v_Boolv] >- (rename1 `Label` \\ rfs [code_rel_def]) - >- (rename1 `FFI` \\ Cases_on `z` \\ Cases_on `z'` \\ fs [data_to_bvi_ref_def,data_to_bvi_v_def] + >- (rename1 `Label` \\ rfs [code_rel_def]) + >- (rename1 `FFI ""` \\ Cases_on `z` \\ Cases_on `z'` \\ fs [data_to_bvi_ref_def,data_to_bvi_v_def] \\ rfs [data_to_bvi_v_def,Unit_def,bvlSemTheory.Unit_def] \\ rw [data_to_bvi_ref_def] \\ rfs [refs_rel_LEAST_eq,lookup_map,lookup_insert]) - >- (rename1 `FFI ""` \\ Cases_on `z` \\ Cases_on `z'` \\ fs [data_to_bvi_ref_def,data_to_bvi_v_def] + >- (rename1 `FFI` \\ Cases_on `z` \\ Cases_on `z'` \\ fs [data_to_bvi_ref_def,data_to_bvi_v_def] \\ rfs [data_to_bvi_v_def,Unit_def,bvlSemTheory.Unit_def] \\ rw [data_to_bvi_ref_def] \\ rfs [refs_rel_LEAST_eq,lookup_map,lookup_insert]) >- (rename1 `Cons` \\ Cases_on `z` diff --git a/compiler/backend/proofs/bvl_to_bviProofScript.sml b/compiler/backend/proofs/bvl_to_bviProofScript.sml index 0209f7d42f..63736ffbfe 100644 --- a/compiler/backend/proofs/bvl_to_bviProofScript.sml +++ b/compiler/backend/proofs/bvl_to_bviProofScript.sml @@ -292,7 +292,8 @@ Proof QED fun cases_on_op q = Cases_on q >| - map (MAP_EVERY Cases_on) [[], [], [`i`], [`w`], [`b`], [`g`], [`m`], []]; + map (MAP_EVERY Cases_on) + [[`n`], [`s`], [`i`], [`w`], [`b`], [`g`], [`m`], [], [`t`]]; Theorem do_app_ok_lemma[local]: state_ok r /\ EVERY (bv_ok r.refs) a /\ @@ -335,6 +336,21 @@ Proof \\ TRY (SRW_TAC [] [] \\ full_simp_tac(srw_ss())[bv_ok_def,EVERY_EL] \\ NO_TAC) \\ TRY (SRW_TAC [] [] \\ full_simp_tac(srw_ss())[bv_ok_def,EVERY_MEM] \\ NO_TAC) \\ STRIP_TAC \\ full_simp_tac(srw_ss())[LET_THM] \\ rpt BasicProvers.VAR_EQ_TAC + >- (rename1 `FFI` >> + full_simp_tac(srw_ss())[state_ok_def] \\ srw_tac[][] >- + (full_simp_tac(srw_ss())[EVERY_MEM] \\ REPEAT STRIP_TAC + \\ BasicProvers.EVERY_CASE_TAC + \\ RES_TAC \\ full_simp_tac(srw_ss())[] + \\ Q.ISPEC_THEN`r.refs`match_mp_tac bv_ok_SUBSET_IMP + \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[SUBSET_DEF,FLOOKUP_DEF]) + \\ simp[FLOOKUP_UPDATE] >> srw_tac[][] >> + BasicProvers.CASE_TAC >> + BasicProvers.CASE_TAC >> + first_x_assum(qspec_then`k`mp_tac) >> srw_tac[][] >> + full_simp_tac(srw_ss())[EVERY_MEM] \\ REPEAT STRIP_TAC + \\ RES_TAC \\ full_simp_tac(srw_ss())[] + \\ Q.ISPEC_THEN`r.refs`match_mp_tac bv_ok_SUBSET_IMP + \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[SUBSET_DEF,FLOOKUP_DEF]) >- (rename1 `FFI` >> full_simp_tac(srw_ss())[state_ok_def] \\ srw_tac[][] >- (full_simp_tac(srw_ss())[EVERY_MEM] \\ REPEAT STRIP_TAC diff --git a/compiler/backend/proofs/clos_annotateProofScript.sml b/compiler/backend/proofs/clos_annotateProofScript.sml index 44afb566a3..7acce66f23 100644 --- a/compiler/backend/proofs/clos_annotateProofScript.sml +++ b/compiler/backend/proofs/clos_annotateProofScript.sml @@ -238,6 +238,12 @@ Proof \\ fs [rich_listTheory.EL_APPEND2] QED +Definition opt_rel_def[simp]: + opt_rel f NONE NONE = T /\ + opt_rel f (SOME x) (SOME y) = f x y /\ + opt_rel f _ _ = F +End + Definition state_rel_def: state_rel (s:('c,'ffi) closSem$state) (t:('c,'ffi) closSem$state) <=> (s.clock = t.clock) /\ @@ -345,6 +351,10 @@ val do_app_lemma = prove( (`ref_rel v_rel (s.refs ' ptr) (t.refs ' ptr)` by fs [] \\ rpt (qpat_x_assum `!x. _` kall_tac) \\ rfs [] \\ Cases_on `s.refs ' ptr` \\ fs [ref_rel_def]) + THEN1 + (`ref_rel v_rel (s.refs ' ptr) (t.refs ' ptr)` by fs [] + \\ rpt (qpat_x_assum `!x. _` kall_tac) \\ rfs [] + \\ Cases_on `s.refs ' ptr` \\ fs [ref_rel_def]) \\ rfs [] \\ fs [FAPPLY_FUPDATE_THM] \\ rveq \\ fs [ref_rel_def] \\ rw []); @@ -579,6 +589,42 @@ val code_tac = EVERY_MAP,EVERY_GENLIST,shift_seq_def] \\ fs[every_Fn_vs_NONE_EVERY_MAP,o_DEF]; +Triviality state_rel_opt_rel_refs: + (state_rel s1 s2 ∧ FLOOKUP s1.refs n = r1 ⇒ + ∃r2. FLOOKUP s2.refs n = r2 ∧ opt_rel (ref_rel v_rel) r1 r2) ∧ + (state_rel s1 s2 ∧ FLOOKUP s2.refs n = r2 ⇒ + ∃r1. FLOOKUP s1.refs n = r1 ∧ opt_rel (ref_rel v_rel) r1 r2) +Proof + rw [] \\ gvs [state_rel_def, FLOOKUP_DEF] \\ rw [] +QED + +Triviality state_rel_clocks_eqs: + state_rel s t ⇒ s.clock = t.clock +Proof + gvs [state_rel_def] +QED + +Triviality rel_update_thunk: + state_rel s1 s2 ∧ + LIST_REL v_rel vs ys ⇒ + (update_thunk [RefPtr v ptr] s1.refs vs = SOME refs1 ⇒ + ∃refs2. update_thunk [RefPtr v ptr] s2.refs ys = SOME refs2 ∧ + state_rel (s1 with refs := refs1) (s2 with refs := refs2)) +Proof + rw [] + \\ gvs [oneline update_thunk_def, AllCaseEqs()] \\ rw [] + \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ ( + gvs [Once v_rel_cases, oneline store_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ rpt ( + imp_res_tac state_rel_opt_rel_refs \\ rw [] + \\ gvs [oneline opt_rel_def] + \\ FULL_CASE_TAC \\ gvs []) + \\ gvs [state_rel_def, FLOOKUP_UPDATE] \\ rw [] + \\ simp [ref_rel_def, Once v_rel_cases] + \\ metis_tac []) +QED + Triviality shift_correct: (!xs env (s1:('c,'ffi) closSem$state) env' t1 res s2 m l i. (evaluate (xs,env,s1) = (res,s2)) /\ res <> Rerr (Rabort Rtype_error) /\ @@ -833,6 +879,25 @@ Proof \\ fs[shift_LENGTH_LEMMA, LENGTH_FST_alt_free] \\ Q.ISPEC_THEN`vs'`FULL_STRUCT_CASES_TAC SNOC_CASES \\ fs[] \\ fs[LIST_REL_SNOC] ) + >- ( (* ThunkOp ThunkForce case *) + gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ rgs [Once v_rel_cases] + \\ imp_res_tac (cj 1 state_rel_opt_rel_refs) + \\ qpat_x_assum `opt_rel (ref_rel v_rel) _ _` mp_tac + \\ simp [oneline opt_rel_def] \\ CASE_TAC \\ gvs [PULL_EXISTS] + \\ imp_res_tac state_rel_clocks_eqs \\ gvs [PULL_EXISTS] + \\ last_x_assum + $ qspecl_then [`[b]`, `dec_clock 1 t2`, `0`, `1`, `i`] mp_tac + \\ ( + gvs [] \\ impl_tac + >- ( + gvs [AppUnit_def, alt_fv, alt_fv1_thm, SUBSET_DEF, IN_DEF, env_ok_def, + dec_clock_def] + \\ code_tac + \\ gvs [state_rel_def]) + \\ rw [AppUnit_def, alt_free_def, shift_def, get_var_def] + \\ goal_assum drule \\ rw [] + \\ drule_all rel_update_thunk \\ rw [])) \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] >> last_x_assum mp_tac >> reverse BasicProvers.CASE_TAC >- ( diff --git a/compiler/backend/proofs/clos_callProofScript.sml b/compiler/backend/proofs/clos_callProofScript.sml index d59240140f..a3fe5a04b1 100644 --- a/compiler/backend/proofs/clos_callProofScript.sml +++ b/compiler/backend/proofs/clos_callProofScript.sml @@ -72,7 +72,8 @@ val _ = export_rewrites["is_Recclosure_def"]; Definition every_refv_def: (every_refv P (ValueArray vs) ⇔ EVERY P vs) ∧ - (every_refv P _ ⇔ T) + (every_refv P (Thunk m v) ⇔ P v) ∧ + (every_refv P _ ⇔ T) End val _ = export_rewrites["every_refv_def"]; @@ -1890,6 +1891,9 @@ Proof \\ Cases_on `op` \\ Cases_on `REVERSE a` \\ simp[do_app_def, case_eq_thms, bool_case_eq, pair_case_eq, CaseEq"ffi$ffi_result"] \\ strip_tac \\ rveq \\ fs [] + \\ TRY ( + rename [`case v of Evaluated => _ | NotEvaluated => _`] + \\ Cases_on `v` \\ gvs []) \\ Cases_on`a` \\ fs[] \\ rveq \\ fs[] \\ strip_tac \\ fs[v_rel_def, PULL_EXISTS] \\ rveq \\ imp_res_tac state_rel_flookup_refs \\ fs[] @@ -1922,6 +1926,11 @@ Proof (res_tac \\ fs [] \\ qpat_x_assum `!x. _` kall_tac \\ rfs [] \\ Cases_on `s.refs ' ptr` \\ fs [ref_rel_def]) + THEN1 + (res_tac \\ fs [] + \\ qpat_x_assum `!x. _` kall_tac + \\ rfs [] \\ Cases_on `s.refs ' ptr` \\ fs [ref_rel_def]) + THEN1 (strip_tac \\ Cases_on `x = p` \\ fs [FAPPLY_FUPDATE_THM]) THEN1 (strip_tac \\ Cases_on `x = p` \\ fs [FAPPLY_FUPDATE_THM]) THEN1 (strip_tac \\ Cases_on `x = p` \\ fs [FAPPLY_FUPDATE_THM])) \\ assume_tac (GEN_ALL simple_val_rel_do_app @@ -1963,6 +1972,8 @@ Proof \\ qspec_tac (`xs`,`xs`) \\ qspec_tac (`ys`,`ys`) \\ Induct \\ fs [] \\ Cases_on `xs` \\ simp_tac std_ss [PULL_EXISTS] \\ fs []) + THEN1 + (match_mp_tac (FEVERY_STRENGTHEN_THM |> CONJUNCT2) \\ fs []) THEN1 (qpat_x_assum `_ xs ys` mp_tac \\ qspec_tac (`ys`,`ys`) \\ qspec_tac (`xs`,`xs`) @@ -2230,7 +2241,7 @@ Proof first_x_assum (fn t => mp_tac t \\ match_mp_tac fmap_rel_mono) \\ rw [] \\ Cases_on `x` \\ Cases_on `y` \\ fs [ref_rel_def] - \\ first_x_assum (fn t => mp_tac t \\ match_mp_tac LIST_REL_mono) + \\ TRY (first_x_assum (fn t => mp_tac t \\ match_mp_tac LIST_REL_mono)) \\ rw [] \\ drule_then irule (GEN_ALL v_rel_SUBMAP_subg) \\ fs [SUBMAP_FUNION_ID, DISJOINT_SYM] @@ -2399,6 +2410,17 @@ Proof \\ EVERY_CASE_TAC \\ rw [] \\ fs [] QED +Triviality state_rel_opt_rel_refs: + (state_rel g l s1 s2 ∧ FLOOKUP s1.refs n = r1 ⇒ + ∃r2. FLOOKUP s2.refs n = r2 ∧ + OPTREL (ref_rel (v_rel g l s2.code)) r1 r2) ∧ + (state_rel g l s1 s2 ∧ FLOOKUP s2.refs n = r2 ⇒ + ∃r1. FLOOKUP s1.refs n = r1 ∧ + OPTREL (ref_rel (v_rel g l s2.code)) r1 r2) +Proof + rw [] \\ gvs [state_rel_def, FLOOKUP_DEF, fmap_rel_def] \\ rw [] +QED + (* compiler correctness *) val t0 = ``t0:('c,'ffi) closSem$state``; @@ -2992,7 +3014,7 @@ Proof \\ strip_tac \\ reverse (Cases_on `q`) \\ fs [] THEN1 (rw [] \\ qexists_tac `ck` \\ asm_exists_tac \\ fs []) - \\ reverse (Cases_on `op = Install`) THEN1 + \\ reverse (Cases_on `op = Install ∨ op = ThunkOp ForceThunk`) THEN1 (fs [] \\ reverse (Cases_on `do_app op (REVERSE a) r`) \\ fs [] THEN1 (rveq \\ fs [] @@ -3013,121 +3035,234 @@ Proof \\ strip_tac \\ pop_assum mp_tac \\ fs [] \\ imp_res_tac do_app_const \\ fs [] \\ strip_tac \\ asm_exists_tac \\ fs []) - \\ rveq \\ fs [] - \\ fs [pair_case_eq] - \\ rveq \\ fs [] - \\ qpat_x_assum `do_install _ r = _` mp_tac - \\ Cases_on `v = Rerr (Rabort Rtype_error)` \\ fs [] - \\ simp [Once do_install_def] - \\ simp [option_case_eq,list_case_eq,PULL_EXISTS,pair_case_eq,bool_case_eq] - \\ pairarg_tac - \\ fs [SWAP_REVERSE_SYM, - Q.INST [`b`|->`DISJOINT (S1 : 'c set) S2 /\ P`] bool_case_eq, - option_case_eq,pair_case_eq,PULL_EXISTS] - \\ rpt gen_tac \\ strip_tac \\ rveq \\ fs [] - \\ `aux = []` by (drule (Q.SPEC `0` code_inv_k) \\ fs [syntax_ok_def]) - \\ Cases_on `r.clock = 0` - THEN1 - (rpt strip_tac \\ fs [] \\ rveq \\ fs [] + \\ rw [] + >~ [`Install`] >- ( + rveq \\ fs [] + \\ fs [pair_case_eq] + \\ rveq \\ fs [] + \\ qpat_x_assum `do_install _ r = _` mp_tac + \\ Cases_on `v = Rerr (Rabort Rtype_error)` \\ fs [] + \\ simp [Once do_install_def] + \\ simp [option_case_eq,list_case_eq,PULL_EXISTS,pair_case_eq,bool_case_eq] + \\ pairarg_tac + \\ fs [SWAP_REVERSE_SYM, + Q.INST [`b`|->`DISJOINT (S1 : 'c set) S2 /\ P`] bool_case_eq, + option_case_eq,pair_case_eq,PULL_EXISTS] + \\ rpt gen_tac \\ strip_tac \\ rveq \\ fs [] + \\ `aux = []` by (drule (Q.SPEC `0` code_inv_k) \\ fs [syntax_ok_def]) + \\ Cases_on `r.clock = 0` + THEN1 + (rpt strip_tac \\ fs [] \\ rveq \\ fs [] + \\ imp_res_tac v_to_bytes_thm + \\ imp_res_tac v_to_words_thm + \\ fs [bool_case_eq] \\ fs [] + \\ fs [] \\ rveq \\ fs [] + \\ `?cfg' progs. t.compile_oracle 0 = (cfg',progs)` by metis_tac [PAIR] + \\ drule (GEN_ALL code_rel_state_rel_install) + \\ rpt (disch_then drule) + \\ simp [] + \\ strip_tac + \\ fs [shift_seq_def] + \\ `exp1 <> []` by + (CCONTR_TAC \\ imp_res_tac calls_length \\ fs [] \\ rveq \\ fs []) + \\ qabbrev_tac `t1 = t with + <|clock := 0; compile_oracle := shift_seq 1 t.compile_oracle; + code := t.code |++ SND progs|>` + \\ qexists_tac `ck` + \\ qexists_tac `t1` + \\ qunabbrev_tac `t1` \\ fs [FUPDATE_LIST, shift_seq_def] + \\ asm_exists_tac + \\ fs [] + \\ conj_tac THEN1 + (`wfv_state g2 l2 t.code + (r with + <| clock := 0; compile_oracle := shift_seq 1 r.compile_oracle; + code := r.code |>)` by fs [wfv_state_def,shift_seq_def] + \\ fs [shift_seq_def,FUPDATE_LIST] + \\ match_mp_tac (GEN_ALL wfv_state_subg) + \\ asm_exists_tac + \\ fs [GSYM FUPDATE_LIST]) + \\ fs [do_install_def] + \\ fs [shift_seq_def] + \\ `t.clock = 0` by fs [state_rel_def] \\ fs [] + \\ rfs [state_rel_def,FUPDATE_LIST] + \\ fs [code_inv_def] + \\ simp [state_co_def] + \\ metis_tac [subg_trans, SUBSET_TRANS]) + \\ fs [bool_case_eq] \\ fs [] + \\ rveq \\ fs [FUPDATE_LIST,shift_seq_def] \\ imp_res_tac v_to_bytes_thm \\ imp_res_tac v_to_words_thm - \\ fs [bool_case_eq] \\ fs [] \\ fs [] \\ rveq \\ fs [] - \\ `?cfg' progs. t.compile_oracle 0 = (cfg',progs)` by metis_tac [PAIR] + \\ ntac 2 (qpat_x_assum `!x._` kall_tac) + \\ `?x23 x34. t.compile_oracle 0 = (x23,x34)` by metis_tac [PAIR] \\ drule (GEN_ALL code_rel_state_rel_install) - \\ rpt (disch_then drule) - \\ simp [] - \\ strip_tac \\ fs [shift_seq_def] + \\ rpt (disch_then drule) \\ strip_tac + \\ `t.clock <> 0` by fs [state_rel_def] \\ fs [] + \\ fs [state_rel_def,FUPDATE_LIST] + \\ Cases_on `evaluate + (exps,[], + r with + <|clock := t.clock − 1; + compile_oracle := (λi. r.compile_oracle (i + 1)); + code := FEMPTY|>)` \\ fs [] \\ rveq \\ fs [] + \\ `q ≠ Rerr (Rabort Rtype_error)` by (every_case_tac \\ fs [] \\ rveq \\ fs []) + \\ fs [] + \\ first_x_assum drule + \\ disch_then (qspecl_then [`[]`,`t with + <|clock := t.clock − 1; + compile_oracle := (λi. t.compile_oracle (i + 1)); + code := FOLDL $|+ t.code aux1|>`, `l2'`, `g2'`] mp_tac) + \\ simp [] \\ rfs [] \\ `exp1 <> []` by (CCONTR_TAC \\ imp_res_tac calls_length \\ fs [] \\ rveq \\ fs []) - \\ qabbrev_tac `t1 = t with - <|clock := 0; compile_oracle := shift_seq 1 t.compile_oracle; - code := t.code |++ SND progs|>` - \\ qexists_tac `ck` - \\ qexists_tac `t1` - \\ qunabbrev_tac `t1` \\ fs [FUPDATE_LIST, shift_seq_def] - \\ asm_exists_tac + \\ reverse impl_tac THEN1 + (strip_tac \\ fs [] \\ rveq \\ fs [] + \\ qpat_x_assum `_ = (Rval _,t)` assume_tac + \\ drule evaluate_add_clock + \\ disch_then (qspec_then `ck'` mp_tac) \\ fs [] \\ strip_tac + \\ qexists_tac `ck+ck'` \\ fs [] \\ rfs [] + \\ fs [do_install_def,shift_seq_def,FUPDATE_LIST] + \\ asm_exists_pat_tac `result_rel (LIST_REL _)` + \\ TOP_CASE_TAC \\ fs [] + \\ FULL_CASE_TAC \\ fs [] \\ rveq \\ fs [] + \\ imp_res_tac evaluate_IMP_LENGTH + \\ fs [LENGTH_EQ_NUM_compute] + \\ rveq \\ fs [] + \\ rename [`EVERY _ aa`] + \\ `aa = [] ∨ ∃x l. aa = SNOC x l` by metis_tac [SNOC_CASES] + THEN1 fs [] \\ full_simp_tac std_ss [LAST_SNOC] \\ fs [EVERY_SNOC] + \\ `a = [] ∨ ∃x l. a = SNOC x l` by metis_tac [SNOC_CASES] + THEN1 fs [] \\ full_simp_tac std_ss [LAST_SNOC] \\ fs [EVERY_SNOC] + \\ fs [LIST_REL_SNOC] + \\ metis_tac [subg_trans, SUBSET_TRANS]) + \\ simp [env_rel_def] \\ rveq \\ fs [] + \\ IMP_RES_THEN MP_TAC (Q.SPEC `0` code_inv_k) + \\ simp [syntax_ok_def] + \\ rpt disch_tac \\ fs [] \\ conj_tac THEN1 - (`wfv_state g2 l2 t.code - (r with - <| clock := 0; compile_oracle := shift_seq 1 r.compile_oracle; - code := r.code |>)` by fs [wfv_state_def,shift_seq_def] - \\ fs [shift_seq_def,FUPDATE_LIST] - \\ match_mp_tac (GEN_ALL wfv_state_subg) - \\ asm_exists_tac - \\ fs [GSYM FUPDATE_LIST]) - \\ fs [do_install_def] - \\ fs [shift_seq_def] - \\ `t.clock = 0` by fs [state_rel_def] \\ fs [] - \\ rfs [state_rel_def,FUPDATE_LIST] - \\ fs [code_inv_def] - \\ simp [state_co_def] - \\ metis_tac [subg_trans, SUBSET_TRANS]) - \\ fs [bool_case_eq] \\ fs [] - \\ rveq \\ fs [FUPDATE_LIST,shift_seq_def] - \\ imp_res_tac v_to_bytes_thm - \\ imp_res_tac v_to_words_thm - \\ fs [] \\ rveq \\ fs [] - \\ ntac 2 (qpat_x_assum `!x._` kall_tac) - \\ `?x23 x34. t.compile_oracle 0 = (x23,x34)` by metis_tac [PAIR] - \\ drule (GEN_ALL code_rel_state_rel_install) - \\ fs [shift_seq_def] - \\ rpt (disch_then drule) \\ strip_tac - \\ `t.clock <> 0` by fs [state_rel_def] \\ fs [] - \\ fs [state_rel_def,FUPDATE_LIST] - \\ Cases_on `evaluate - (exps,[], - r with - <|clock := t.clock − 1; - compile_oracle := (λi. r.compile_oracle (i + 1)); - code := FEMPTY|>)` \\ fs [] \\ rveq \\ fs [] - \\ `q ≠ Rerr (Rabort Rtype_error)` by (every_case_tac \\ fs [] \\ rveq \\ fs []) - \\ fs [] - \\ first_x_assum drule - \\ disch_then (qspecl_then [`[]`,`t with + (`wfv_state g2 l2 t.code (r with <|clock := t.clock − 1; - compile_oracle := (λi. t.compile_oracle (i + 1)); - code := FOLDL $|+ t.code aux1|>`, `l2'`, `g2'`] mp_tac) - \\ simp [] \\ rfs [] - \\ `exp1 <> []` by - (CCONTR_TAC \\ imp_res_tac calls_length \\ fs [] \\ rveq \\ fs []) - \\ reverse impl_tac THEN1 - (strip_tac \\ fs [] \\ rveq \\ fs [] - \\ qpat_x_assum `_ = (Rval _,t)` assume_tac - \\ drule evaluate_add_clock - \\ disch_then (qspec_then `ck'` mp_tac) \\ fs [] \\ strip_tac - \\ qexists_tac `ck+ck'` \\ fs [] \\ rfs [] - \\ fs [do_install_def,shift_seq_def,FUPDATE_LIST] - \\ asm_exists_pat_tac `result_rel (LIST_REL _)` - \\ TOP_CASE_TAC \\ fs [] - \\ FULL_CASE_TAC \\ fs [] \\ rveq \\ fs [] - \\ imp_res_tac evaluate_IMP_LENGTH - \\ fs [LENGTH_EQ_NUM_compute] - \\ rveq \\ fs [] - \\ rename [`EVERY _ aa`] - \\ `aa = [] ∨ ∃x l. aa = SNOC x l` by metis_tac [SNOC_CASES] - THEN1 fs [] \\ full_simp_tac std_ss [LAST_SNOC] \\ fs [EVERY_SNOC] - \\ `a = [] ∨ ∃x l. a = SNOC x l` by metis_tac [SNOC_CASES] - THEN1 fs [] \\ full_simp_tac std_ss [LAST_SNOC] \\ fs [EVERY_SNOC] - \\ fs [LIST_REL_SNOC] - \\ metis_tac [subg_trans, SUBSET_TRANS]) - \\ simp [env_rel_def] \\ rveq \\ fs [] - \\ IMP_RES_THEN MP_TAC (Q.SPEC `0` code_inv_k) - \\ simp [syntax_ok_def] - \\ rpt disch_tac - \\ fs [] - \\ conj_tac THEN1 - (`wfv_state g2 l2 t.code (r with - <|clock := t.clock − 1; - compile_oracle := (λi. r.compile_oracle (i + 1)); code := FEMPTY|>)` - by (fs [code_inv_def,wfv_state_def] \\ fs [] \\ rfs []) - \\ match_mp_tac (GEN_ALL wfv_state_subg) - \\ asm_exists_tac \\ fs [GSYM FUPDATE_LIST]) - \\ fs [code_inv_def, wfg_subg_refl] - \\ rfs [] - \\ fs [code_includes_def]) + compile_oracle := (λi. r.compile_oracle (i + 1)); code := FEMPTY|>)` + by (fs [code_inv_def,wfv_state_def] \\ fs [] \\ rfs []) + \\ match_mp_tac (GEN_ALL wfv_state_subg) + \\ asm_exists_tac \\ fs [GSYM FUPDATE_LIST]) + \\ fs [code_inv_def, wfg_subg_refl] + \\ rfs [] + \\ fs [code_includes_def]) + >~ [`ThunkOp ForceThunk`] >- ( + gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] + >- ( + gvs [v_rel_def] + \\ rpt (goal_assum drule \\ gvs []) + \\ rw [GSYM PULL_EXISTS] + >- ( + gvs [wfv_state_def, FEVERY_ALL_FLOOKUP] + \\ first_x_assum drule \\ rw []) + \\ goal_assum drule \\ gvs [] + \\ drule_all state_rel_flookup_refs \\ rw [] \\ gvs []) + >- ( + gvs [v_rel_def] + \\ rpt (goal_assum drule \\ gvs []) + \\ drule_all state_rel_flookup_refs \\ rw [] \\ gvs [] + \\ imp_res_tac state_rel_clock \\ gvs []) + >- ( + gvs [v_rel_def] + \\ gvs [AppUnit_def, calls_def, code_locs_def] + \\ drule_all_then assume_tac state_rel_flookup_refs \\ gvs [] + \\ `state_rel g2 l2 (dec_clock 1 r) (dec_clock 1 t)` by ( + gvs [state_rel_def, dec_clock_def]) + \\ first_x_assum $ drule_at (Pat `state_rel _ _ (dec_clock _ _) _`) + \\ gvs [] + \\ disch_then $ qspecl_then [`g`, `[b]`] mp_tac + \\ impl_tac + >- ( + rw [] + >- gvs [code_inv_def, dec_clock_def] + >- ( + gvs [dec_clock_def, wfv_state_def, FEVERY_ALL_FLOOKUP] + \\ first_x_assum drule \\ rw []) + >- gvs [wfv_state_def, dec_clock_def] + >- (irule calls_wfg \\ metis_tac[]) + >- imp_res_tac subg_trans + >- gvs [env_rel_def, dec_clock_def] + >- ( + `(dec_clock 1 t).code = t.code` + by gvs [state_rel_def, dec_clock_def] + \\ gvs [] + \\ irule code_includes_SUBMAP + \\ goal_assum $ drule_at Any \\ rw [] + \\ imp_res_tac evaluate_mono \\ gvs [])) + \\ rw [] \\ gvs [] + \\ qrefinel [`_`, `t' with refs := refs1`] \\ gvs[] + \\ goal_assum drule \\ gvs [] + \\ `subg g1 g2'` by (imp_res_tac subg_trans \\ gvs []) \\ gvs [] + \\ `l1 ⊆ l2'` by (imp_res_tac SUBSET_TRANS \\ gvs []) \\ gvs [] + \\ `wfv_state g2' l2' t'.code (s'' with refs := refs)` by ( + gvs [wfv_state_def, FEVERY_ALL_FLOOKUP, FLOOKUP_UPDATE] \\ rw [] + \\ gvs [oneline update_thunk_def, AllCaseEqs()] + \\ gvs [store_thunk_def, AllCaseEqs()] + \\ gvs [FLOOKUP_UPDATE] + \\ Cases_on `ptr = k` \\ gvs [] + \\ first_x_assum drule \\ gvs []) \\ gvs [] + \\ qrefinel [`_`, `ck'' + ck`] + \\ `∀ck''. evaluate (e1,env2,t0 with clock := ck + ck'' + t0.clock) = + (Rval [RefPtr v0 ptr],t with clock := ck'' + t.clock)` by ( + imp_res_tac evaluate_add_clock \\ gvs []) + \\ gvs [PULL_EXISTS] + \\ imp_res_tac state_rel_clock \\ gvs [PULL_EXISTS, dec_clock_def] + \\ goal_assum drule \\ gvs [] + \\ gvs [oneline update_thunk_def, AllCaseEqs()] \\ rw [] + \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ ( + gvs [v_rel_def, oneline store_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ rpt ( + drule (GEN_ALL $ cj 1 state_rel_opt_rel_refs) + \\ disch_then dxrule \\ rw [OPTREL_def] \\ gvs []) + \\ qmatch_goalsub_abbrev_tac `t' with refs := trefs` + \\ qexists `trefs` \\ unabbrev_all_tac \\ gvs [] + \\ gvs [state_rel_def, fmap_rel_def, FAPPLY_FUPDATE_THM] \\ rw [] + \\ simp [v_rel_def])) + >- ( + gvs [v_rel_def] + \\ gvs [AppUnit_def, calls_def, code_locs_def] + \\ drule_all_then assume_tac state_rel_flookup_refs \\ gvs [] + \\ `state_rel g2 l2 (dec_clock 1 r) (dec_clock 1 t)` by ( + gvs [state_rel_def, dec_clock_def]) + \\ first_x_assum $ drule_at (Pat `state_rel _ _ (dec_clock _ _) _`) + \\ gvs [] + \\ disch_then $ qspecl_then [`g`, `[b]`] mp_tac + \\ impl_tac + >- ( + rw [] + >- gvs [code_inv_def, dec_clock_def] + >- ( + gvs [dec_clock_def, wfv_state_def, FEVERY_ALL_FLOOKUP] + \\ first_x_assum drule \\ rw []) + >- gvs [wfv_state_def, dec_clock_def] + >- (irule calls_wfg \\ metis_tac[]) + >- imp_res_tac subg_trans + >- gvs [env_rel_def, dec_clock_def] + >- ( + `(dec_clock 1 t).code = t.code` + by gvs [state_rel_def, dec_clock_def] + \\ gvs [] + \\ irule code_includes_SUBMAP + \\ goal_assum $ drule_at Any \\ rw [] + \\ imp_res_tac evaluate_mono \\ gvs [])) + \\ rw [] \\ gvs [] + \\ goal_assum drule \\ gvs [] + \\ `subg g1 g2'` by (imp_res_tac subg_trans \\ gvs []) \\ gvs [] + \\ `l1 ⊆ l2'` by (imp_res_tac SUBSET_TRANS \\ gvs []) \\ gvs [] + \\ qrefine `ck'' + ck` + \\ `∀ck''. evaluate (e1,env2,t0 with clock := ck + ck'' + t0.clock) = + (Rval [RefPtr v0 ptr],t with clock := ck'' + t.clock)` by ( + imp_res_tac evaluate_add_clock \\ gvs []) + \\ gvs [PULL_EXISTS] + \\ imp_res_tac state_rel_clock \\ gvs [PULL_EXISTS, dec_clock_def] + \\ goal_assum drule \\ gvs []))) (* Fn *) \\ conj_tac >- ( say "Fn" diff --git a/compiler/backend/proofs/clos_fvsProofScript.sml b/compiler/backend/proofs/clos_fvsProofScript.sml index 74279e176b..48e2787395 100644 --- a/compiler/backend/proofs/clos_fvsProofScript.sml +++ b/compiler/backend/proofs/clos_fvsProofScript.sml @@ -97,7 +97,16 @@ Inductive ref_rel: (!bs. ref_rel (ByteArray bs) (ByteArray bs)) /\ (!xs ys. LIST_REL v_rel xs ys ==> - ref_rel (ValueArray xs) (ValueArray ys)) + ref_rel (ValueArray xs) (ValueArray ys)) /\ + (!m v w. + v_rel v w ==> + ref_rel (Thunk m v) (Thunk m w)) +End + +Definition opt_rel_def[simp]: + opt_rel f NONE NONE = T /\ + opt_rel f (SOME x) (SOME y) = f x y /\ + opt_rel f _ _ = F End Definition state_rel_def: @@ -263,6 +272,50 @@ val do_install_lemma = prove( simple_val_rel_def] \\ fs [v_rel_cases]); +Triviality state_rel_opt_rel_refs: + (state_rel s1 s2 ∧ FLOOKUP s1.refs n = r1 ⇒ + ∃r2. FLOOKUP s2.refs n = r2 ∧ opt_rel ref_rel r1 r2) ∧ + (state_rel s1 s2 ∧ FLOOKUP s2.refs n = r2 ⇒ + ∃r1. FLOOKUP s1.refs n = r1 ∧ opt_rel ref_rel r1 r2) +Proof + rw [] \\ gvs [state_rel_def, fmap_rel_def, FLOOKUP_DEF] \\ rw [] +QED + +Triviality state_rel_clocks_eqs: + state_rel s1 s2 ⇒ s1.clock = s2.clock +Proof + rw [state_rel_def, state_component_equality] +QED + +Triviality state_rel_dec_clock: + state_rel s1 s2 ⇒ state_rel (dec_clock 1 s1) (dec_clock 1 s2) +Proof + rw [state_rel_def, dec_clock_def, state_component_equality] +QED + +Triviality rel_update_thunk: + state_rel s1 s2 ∧ + LIST_REL v_rel vs ys ⇒ + (update_thunk [RefPtr v ptr] s1.refs vs = NONE ⇒ + update_thunk [RefPtr v ptr] s2.refs ys = NONE) ∧ + (update_thunk [RefPtr v ptr] s1.refs vs = SOME refs1 ⇒ + ∃refs2. update_thunk [RefPtr v ptr] s2.refs ys = SOME refs2 ∧ + state_rel (s1 with refs := refs1) (s2 with refs := refs2)) +Proof + rw [] + \\ gvs [oneline update_thunk_def, AllCaseEqs()] \\ rw [] + \\ gvs [oneline dest_thunk_def, AllCaseEqs()] + \\ ( + gvs [Once v_rel_cases, oneline store_thunk_def, AllCaseEqs()] + \\ rpt ( + imp_res_tac state_rel_opt_rel_refs \\ rw [] + \\ gvs [oneline opt_rel_def] + \\ FULL_CASE_TAC \\ gvs [] + \\ rgs [Once ref_rel_cases]) + \\ gvs [state_rel_def, fmap_rel_def, FAPPLY_FUPDATE_THM] \\ rw [] + \\ simp [Once ref_rel_cases]) +QED + (* evaluate level correctness *) Theorem evaluate_remove_fvs: @@ -391,7 +444,18 @@ Proof \\ fs [] \\ CCONTR_TAC \\ fs []) - (* op <> Install *) + \\ IF_CASES_TAC \\ rveq \\ fs [] >- ((* Op = ThunkOp ForceThunk *) + gvs [oneline dest_thunk_def, AllCaseEqs()] + \\ imp_res_tac (cj 1 state_rel_opt_rel_refs) + \\ qpat_x_assum `opt_rel ref_rel _ _` mp_tac + \\ simp [oneline opt_rel_def] \\ CASE_TAC \\ gvs [] + \\ rgs [Once ref_rel_cases] + \\ imp_res_tac state_rel_clocks_eqs \\ gvs [PULL_EXISTS] + \\ imp_res_tac state_rel_dec_clock \\ gvs [] + \\ last_x_assum drule_all \\ rw [AppUnit_def, remove_fvs_def] + \\ goal_assum drule \\ rw [] + \\ drule_all rel_update_thunk \\ rw []) + (* op <> Install ∧ op <> ThunkOp ForceThunk *) \\ drule EVERY2_REVERSE \\ disch_tac \\ drule (GEN_ALL do_app_lemma) \\ disch_then drule diff --git a/compiler/backend/proofs/clos_interpProofScript.sml b/compiler/backend/proofs/clos_interpProofScript.sml index 276d646b0e..b75bbf87e2 100644 --- a/compiler/backend/proofs/clos_interpProofScript.sml +++ b/compiler/backend/proofs/clos_interpProofScript.sml @@ -732,6 +732,27 @@ Proof \\ gvs [AllCaseEqs()] QED +Triviality state_rel_refs_clocks_eqs: + state_rel s1 s2 ⇒ s1.refs = s2.refs ∧ s1.clock = s2.clock +Proof + rw [state_rel_def, state_component_equality] +QED + +Triviality state_rel_update_thunk: + state_rel s1 s2 ⇒ + update_thunk [RefPtr v ptr] s1.refs vs = SOME refs1 ⇒ + ∃refs2. update_thunk [RefPtr v ptr] s2.refs vs = SOME refs2 ∧ + state_rel (s1 with refs := refs1) (s2 with refs := refs2) +Proof + rw [] + \\ gvs [oneline update_thunk_def, AllCaseEqs()] \\ rw [] + \\ gvs [oneline dest_thunk_def, AllCaseEqs()] + \\ ( + gvs [oneline store_thunk_def, AllCaseEqs()] + \\ imp_res_tac state_rel_refs_clocks_eqs \\ gvs [] + \\ gvs [state_rel_def]) +QED + Theorem evaluate_interp_lemma: (∀xs (s1:('c,'ffi) closSem$state) env t1 res s2. (evaluate (xs,env,s1) = (res,s2)) ∧ res <> Rerr (Rabort Rtype_error) ⇒ @@ -952,7 +973,7 @@ Proof \\ strip_tac \\ reverse $ gvs [CaseEq"result"] >- (qexists_tac ‘ck’ \\ fs []) - \\ Cases_on ‘p ≠ Install’ \\ gvs [] + \\ Cases_on ‘p ≠ Install ∧ p ≠ ThunkOp ForceThunk’ \\ gvs [] \\ gvs [evaluate_def,CaseEq"prod",PULL_EXISTS] >- (qabbrev_tac ‘vr = λv1 v2. v1 = v2:closSem$v’ @@ -976,57 +997,79 @@ Proof \\ gvs [Abbr‘vr’] >- (Cases_on ‘err’ \\ gvs []) \\ fs [state_rel_def,state_rel_1_def] \\ drule_then irule do_app_oHD_globals \\ fs []) - \\ rename [‘state_rel s3 t3’] - \\ qpat_x_assum ‘do_install _ _ = _’ mp_tac - \\ simp [Once do_install_def] - \\ simp [AllCaseEqs()] \\ strip_tac \\ gvs [] - \\ pairarg_tac \\ gvs [] - \\ gvs [CaseEq"bool"] - \\ gvs [CaseEq"option"] - \\ gvs [CaseEq"prod"] - \\ ‘s3.compile = pure_cc (insert_interp ## I) t3.compile ∧ - t3.compile_oracle = pure_co (insert_interp ## I) ∘ s3.compile_oracle ∧ - t3.clock = s3.clock ∧ - FDOM t3.code = EMPTY ∧ FDOM s3.code = EMPTY’ - by fs [state_rel_def] - \\ ‘insert_interp exps ≠ []’ by (gvs [insert_interp_def] \\ gvs [AllCaseEqs()]) - \\ gvs [CaseEq"bool"] - >- - (qexists_tac ‘ck’ \\ fs [] - \\ simp [do_install_def] - \\ fs [pure_co_def,pure_cc_def] - \\ fs [o_DEF,shift_seq_def] - \\ fs [state_rel_def,FUN_EQ_THM] - \\ rpt (first_x_assum (qspec_then ‘0:num’ assume_tac) \\ gvs [FUPDATE_LIST])) - \\ ‘aux = []’ by - (fs [state_rel_def,FUN_EQ_THM] - \\ rpt (first_x_assum (qspec_then ‘0:num’ assume_tac) \\ gvs [FUPDATE_LIST])) - \\ gvs [SWAP_REVERSE_SYM,CaseEq"prod"] - \\ drule_at (Pos $ el 2) evaluate_insert_interp \\ fs [FUPDATE_LIST] - \\ disch_then $ qspec_then ‘t3 with - <|clock := t3.clock − 1; - compile_oracle := shift_seq 1 t3.compile_oracle; - code := t3.code |>’ mp_tac - \\ impl_tac - >- - (fs [interp_assum_def] \\ rpt strip_tac + >~ [`Install`] >- ( + rename [‘state_rel s3 t3’] + \\ qpat_x_assum ‘do_install _ _ = _’ mp_tac + \\ simp [Once do_install_def] + \\ simp [AllCaseEqs()] \\ strip_tac \\ gvs [] + \\ pairarg_tac \\ gvs [] + \\ gvs [CaseEq"bool"] + \\ gvs [CaseEq"option"] + \\ gvs [CaseEq"prod"] + \\ ‘s3.compile = pure_cc (insert_interp ## I) t3.compile ∧ + t3.compile_oracle = pure_co (insert_interp ## I) ∘ s3.compile_oracle ∧ + t3.clock = s3.clock ∧ + FDOM t3.code = EMPTY ∧ FDOM s3.code = EMPTY’ + by fs [state_rel_def] + \\ ‘insert_interp exps ≠ []’ by (gvs [insert_interp_def] \\ gvs [AllCaseEqs()]) + \\ gvs [CaseEq"bool"] >- - (last_x_assum irule \\ fs [] - \\ first_assum $ irule_at Any \\ fs [] - \\ imp_res_tac evaluate_clock \\ fs []) + (qexists_tac ‘ck’ \\ fs [] + \\ simp [do_install_def] + \\ fs [pure_co_def,pure_cc_def] + \\ fs [o_DEF,shift_seq_def] + \\ fs [state_rel_def,FUN_EQ_THM] + \\ rpt (first_x_assum (qspec_then ‘0:num’ assume_tac) \\ gvs [FUPDATE_LIST])) + \\ ‘aux = []’ by + (fs [state_rel_def,FUN_EQ_THM] + \\ rpt (first_x_assum (qspec_then ‘0:num’ assume_tac) \\ gvs [FUPDATE_LIST])) + \\ gvs [SWAP_REVERSE_SYM,CaseEq"prod"] + \\ drule_at (Pos $ el 2) evaluate_insert_interp \\ fs [FUPDATE_LIST] + \\ disch_then $ qspec_then ‘t3 with + <|clock := t3.clock − 1; + compile_oracle := shift_seq 1 t3.compile_oracle; + code := t3.code |>’ mp_tac + \\ impl_tac >- - (last_x_assum irule \\ fs [] - \\ first_assum $ irule_at Any \\ fs [] - \\ imp_res_tac evaluate_clock \\ fs []) - \\ gvs [FUN_EQ_THM,shift_seq_def,state_rel_def]) - \\ strip_tac - \\ qpat_x_assum ‘evaluate _ = (Rval _,_)’ assume_tac - \\ drule evaluate_add_clock \\ fs [] - \\ disch_then $ qspec_then ‘ck'’ assume_tac - \\ qexists_tac ‘ck+ck'’ \\ fs [PULL_EXISTS] - \\ fs [do_install_def,pure_co_def,shift_seq_def,pure_cc_def,pure_co_def,PULL_EXISTS] - \\ gvs [FUPDATE_LIST] - \\ gvs [AllCaseEqs()] + (fs [interp_assum_def] \\ rpt strip_tac + >- + (last_x_assum irule \\ fs [] + \\ first_assum $ irule_at Any \\ fs [] + \\ imp_res_tac evaluate_clock \\ fs []) + >- + (last_x_assum irule \\ fs [] + \\ first_assum $ irule_at Any \\ fs [] + \\ imp_res_tac evaluate_clock \\ fs []) + \\ gvs [FUN_EQ_THM,shift_seq_def,state_rel_def]) + \\ strip_tac + \\ qpat_x_assum ‘evaluate _ = (Rval _,_)’ assume_tac + \\ drule evaluate_add_clock \\ fs [] + \\ disch_then $ qspec_then ‘ck'’ assume_tac + \\ qexists_tac ‘ck+ck'’ \\ fs [PULL_EXISTS] + \\ fs [do_install_def,pure_co_def,shift_seq_def,pure_cc_def,pure_co_def,PULL_EXISTS] + \\ gvs [FUPDATE_LIST] + \\ gvs [AllCaseEqs()]) + >~ [`ThunkOp ForceThunk`] >- ( + gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ qrefine `ck + ck'` \\ gvs [] + \\ `∀ck'. evaluate (xs,env,t1 with clock := ck + (ck' + t1.clock)) = + (Rval [RefPtr v0 ptr],t2 with clock := ck' + t2.clock)` by ( + rw [] \\ drule evaluate_add_clock \\ gvs []) \\ gvs [] + \\ imp_res_tac state_rel_refs_clocks_eqs \\ gvs [PULL_EXISTS] + >- (qexists `0` \\ gvs [state_rel_def]) + >- (qexists `0` \\ gvs [state_rel_def]) + \\ ( + last_x_assum $ qspecl_then [`[AppUnit (Var None 0)]`, + `s' with clock := t2.clock - 1`] mp_tac + \\ gvs [GSYM PULL_FORALL] + \\ impl_tac + >- (imp_res_tac evaluate_clock \\ gvs []) + \\ disch_then $ qspec_then `[f]` mp_tac \\ gvs [dec_clock_def] + \\ disch_then $ qspec_then `dec_clock 1 t2` mp_tac \\ gvs [dec_clock_def] + \\ impl_tac + >- gvs [state_rel_def] \\ rw [] + \\ goal_assum drule \\ gvs [] + \\ imp_res_tac state_rel_update_thunk \\ rw [])) QED Theorem evaluate_interp_thm: @@ -1074,7 +1117,9 @@ Definition state_rel'_def: t.clock = s.clock ∧ t.ffi = s.ffi ∧ s.globals = t.globals ∧ EVERY (OPTION_ALL v_ok) t.globals ∧ - s.refs = t.refs ∧ FEVERY (λ(k,v). ∀vs. v = ValueArray vs ⇒ EVERY v_ok vs) t.refs ∧ + s.refs = t.refs ∧ + FEVERY (λ(k,v). ∀vs. v = ValueArray vs ⇒ EVERY v_ok vs) t.refs ∧ + FEVERY (λ(k,v). ∀m w. v = Thunk m w ⇒ v_ok w) t.refs ∧ s.compile = pure_cc (insert_interp ## I) t.compile ∧ t.compile_oracle = pure_co (insert_interp ## I) o s.compile_oracle End @@ -1094,6 +1139,18 @@ Proof fs [state_rel'_def] QED +Triviality state_rel'_refs: + state_rel' s t ⇒ t.refs = s.refs +Proof + fs [state_rel'_def] +QED + +Triviality state_rel'_dec_clock: + state_rel' s t ⇒ state_rel' (dec_clock 1 s) (dec_clock 1 t) +Proof + gvs [state_rel'_def, dec_clock_def] +QED + Triviality has_install_list_eq: ∀xs. has_install_list xs ⇔ EXISTS has_install xs Proof @@ -1184,8 +1241,12 @@ Proof \\ qid_spec_tac ‘vs’ \\ Induct \\ gvs [Abbr‘vr’]) \\ fs [simple_state_rel_def] \\ simp [Abbr‘vr’] \\ rpt $ pop_assum kall_tac \\ rw [] \\ gvs [state_rel'_def] - \\ TRY $ drule_all FEVERY_FLOOKUP \\ fs [] - >- (qid_spec_tac ‘w’ \\ Induct \\ fs []) + >- ( + imp_res_tac FEVERY_FLOOKUP \\ pairarg_tac + \\ gvs [EVERY_EL, LIST_REL_EL_EQN]) + >- ( + imp_res_tac FEVERY_FLOOKUP \\ pairarg_tac + \\ gvs [EVERY_EL, LIST_REL_EL_EQN]) >- (qpat_x_assum ‘EVERY _ _’ mp_tac \\ rename [‘EVERY _ xs’] \\ qid_spec_tac ‘xs’ \\ Induct \\ fs [] \\ Cases \\ fs []) @@ -1196,6 +1257,8 @@ Proof (pop_assum mp_tac \\ qid_spec_tac ‘xs’ \\ qid_spec_tac ‘ys’ \\ Induct \\ fs [PULL_EXISTS] \\ rw [] \\ gvs [] \\ res_tac \\ fs []) \\ gvs [] \\ rw [] \\ fs [] \\ res_tac \\ fs []) + >- (gvs [FEVERY_DEF,SF DNF_ss,FAPPLY_FUPDATE_THM] \\ rw [] + \\ res_tac \\ fs []) \\ pop_assum mp_tac \\ qid_spec_tac ‘xs’ \\ qid_spec_tac ‘ys’ @@ -1204,6 +1267,32 @@ Proof \\ Cases_on ‘h’ \\ fs [] \\ Cases_on ‘x’ \\ fs [] \\ gvs []) \\ strip_tac + \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs [] + >- ( + gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ imp_res_tac state_rel'_refs \\ gvs [] + \\ imp_res_tac state_rel'_clock \\ gvs [PULL_EXISTS] + >- ( + gvs [state_rel'_def] + \\ imp_res_tac FEVERY_FLOOKUP + \\ rpt (pairarg_tac \\ gvs [])) + \\ ( + gvs [AppUnit_def, has_install_def] + \\ imp_res_tac state_rel'_dec_clock + \\ last_x_assum drule + \\ impl_tac + >- ( + gvs [state_rel'_def] + \\ imp_res_tac FEVERY_FLOOKUP + \\ rpt (pairarg_tac \\ gvs [])) + \\ rw [] \\ gvs [] + \\ gvs [oneline update_thunk_def, AllCaseEqs()] + \\ gvs [oneline dest_thunk_def, AllCaseEqs()] + \\ gvs [oneline store_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ imp_res_tac state_rel'_refs \\ gvs [] + \\ gvs [state_rel'_def] + \\ gvs [FEVERY_DEF,FAPPLY_FUPDATE_THM] \\ rw [] + \\ res_tac \\ fs [])) \\ gvs [AllCaseEqs()] \\ gvs [Abbr‘vr’] \\ Cases_on ‘err’ \\ gvs []) diff --git a/compiler/backend/proofs/clos_knownProofScript.sml b/compiler/backend/proofs/clos_knownProofScript.sml index e777c5d1a9..48dfb5ec5c 100644 --- a/compiler/backend/proofs/clos_knownProofScript.sml +++ b/compiler/backend/proofs/clos_knownProofScript.sml @@ -645,6 +645,9 @@ Proof \\ gvs [EL_REPLICATE]) >- (fs [CaseEq"ffi_result"] \\ rveq \\ fs [state_globals_approx_def] \\ metis_tac []) + >- ( + rename1 `FLOOKUP _ _ = SOME (Thunk m _)` + \\ Cases_on `m` \\ gvs []) QED Theorem ssgc_free_co_shift_seq: @@ -673,6 +676,7 @@ Proof \\ rveq \\ fs [MAP_APPEND, elist_globals_append]) THEN1 (rw [] \\ res_tac) + THEN1 (rw [] \\ res_tac) THEN1 (simp [shift_seq_def] \\ rw [] \\ res_tac) QED @@ -735,6 +739,7 @@ Proof >- (irule IMP_EVERY_LUPDATE >> simp[] >> metis_tac[]) >- metis_tac[] >- metis_tac[] + >- metis_tac[] >- metis_tac[]) >- (rename [‘El’] \\ simp[PULL_FORALL] \\ rw [] \\ fs [ssgc_free_def] \\ res_tac @@ -766,6 +771,7 @@ Proof >- metis_tac[] >- metis_tac[] >- (fs[MEM_LUPDATE] >> metis_tac[MEM_EL]) + >- (fs[MEM_LUPDATE] >> metis_tac[MEM_EL]) >- metis_tac[] >- metis_tac[] >- (dsimp[SUBSET_DEF, get_global_def, @@ -811,13 +817,13 @@ Proof >- (rename [‘EqualConst’] \\ rw [] \\ fs [Boolv_def]) >- (rename [‘FFI’] \\ dsimp[ssgc_free_def, FLOOKUP_UPDATE, bool_case_eq] >> - rpt strip_tac >> PURE_FULL_CASE_TAC >> fs [] >> rveq - >- (first_x_assum match_mp_tac >> fs[FLOOKUP_UPDATE,bool_case_eq] >> metis_tac[]) - >- (fs[ssgc_free_def,FLOOKUP_UPDATE, bool_case_eq] >> metis_tac[]) - >- (last_x_assum match_mp_tac >> fs[]) - >- (first_x_assum match_mp_tac >> fs[] >> metis_tac[]) - >- (first_x_assum match_mp_tac >> fs[] >> metis_tac[]) - \\ dsimp[ssgc_free_def, FLOOKUP_UPDATE, bool_case_eq]) + rpt strip_tac >> PURE_FULL_CASE_TAC >> fs [] >> rveq >> + fs[ssgc_free_def,FLOOKUP_UPDATE, bool_case_eq] >> metis_tac[]) + >- (rename [‘ThunkOp’] >> + dsimp[ssgc_free_def, FLOOKUP_UPDATE, bool_case_eq] >> + rpt strip_tac >> + rpt (FULL_CASE_TAC >> gvs []) >> fs [] >> rveq >> + fs[ssgc_free_def,FLOOKUP_UPDATE, bool_case_eq] >> metis_tac[]) QED Theorem dest_closure_Full_sgc_free: @@ -850,6 +856,21 @@ Proof THEN1 (irule EVERY_DROP \\ simp [EVERY_REVERSE]) QED +Triviality update_thunk_ssgc_free: + ssgc_free s ∧ + EVERY vsgc_free vs ∧ + update_thunk [RefPtr v ptr] s.refs vs = SOME refs ⇒ + ssgc_free (s with refs := refs) +Proof + rw [] + \\ gvs [oneline update_thunk_def, AllCaseEqs()] + \\ gvs [oneline dest_thunk_def, AllCaseEqs()] + \\ ( + gvs [store_thunk_def, AllCaseEqs()] + \\ gvs [ssgc_free_def, FLOOKUP_UPDATE] \\ rw [] + \\ rpt (first_x_assum drule \\ rw [])) +QED + val say = say0 "evaluate_changed_globals_0"; (* Evaluate *) @@ -1011,6 +1032,74 @@ Proof \\ rpt (pop_assum kall_tac) \\ fs [elist_globals_append, SET_OF_BAG_UNION] \\ metis_tac [UNION_ASSOC, UNION_COMM, SUBSET_UNION]) + \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs [] + THEN1 + ( + gvs [oneline dest_thunk_def, AllCaseEqs()] + >- goal_assum drule + \\ TRY ( + qexists `n` \\ gvs [SET_OF_BAG_UNION] + \\ metis_tac [mglobals_extend_SUBSET, UNION_ASSOC, SUBSET_UNION]) + >- ( + gvs [ssgc_free_def] + \\ rpt (first_x_assum drule \\ rw []) + \\ qexists `n` \\ gvs [SET_OF_BAG_UNION] + \\ metis_tac [mglobals_extend_SUBSET, UNION_ASSOC, SUBSET_UNION]) + >- ( + gvs [Once AppUnit_def] + \\ `vsgc_free f` by ( + gvs [ssgc_free_def] + \\ rpt (first_x_assum drule \\ rw [])) \\ gvs [dec_clock_def] + \\ qexists `n' + n` + \\ simp [first_n_exps_shift_seq] + \\ qmatch_asmsub_abbrev_tac `mglobals_extend s0.globals g1 s1.globals` + \\ qmatch_asmsub_abbrev_tac `mglobals_extend s1.globals g2 s.globals` + \\ qmatch_goalsub_abbrev_tac `mglobals_extend s0.globals g3 s.globals` + \\ rfs [] + \\ `g1 ∪ g2 ⊆ g3` suffices_by + metis_tac [mglobals_extend_trans, mglobals_extend_SUBSET] + \\ unabbrev_all_tac + \\ rpt (pop_assum kall_tac) + \\ gvs [elist_globals_append, SET_OF_BAG_UNION, AppUnit_def, + op_gbag_def] + \\ metis_tac [UNION_ASSOC, UNION_COMM, SUBSET_UNION]) + >- ( + gvs [Once AppUnit_def] + \\ `vsgc_free f` by ( + gvs [ssgc_free_def] + \\ rpt (first_x_assum drule \\ rw [])) \\ gvs [dec_clock_def] + \\ conj_tac >- (drule_all update_thunk_ssgc_free \\ gvs []) + \\ qexists `n' + n` + \\ simp [first_n_exps_shift_seq] + \\ qmatch_asmsub_abbrev_tac `mglobals_extend s0.globals g1 s1.globals` + \\ qmatch_asmsub_abbrev_tac `mglobals_extend s1.globals g2 s.globals` + \\ qmatch_goalsub_abbrev_tac `mglobals_extend s0.globals g3 s.globals` + \\ rfs [] + \\ `g1 ∪ g2 ⊆ g3` suffices_by + metis_tac [mglobals_extend_trans, mglobals_extend_SUBSET] + \\ unabbrev_all_tac + \\ rpt (pop_assum kall_tac) + \\ gvs [elist_globals_append, SET_OF_BAG_UNION, AppUnit_def, + op_gbag_def] + \\ metis_tac [UNION_ASSOC, UNION_COMM, SUBSET_UNION]) + >- ( + gvs [Once AppUnit_def] + \\ `vsgc_free f` by ( + gvs [ssgc_free_def] + \\ rpt (first_x_assum drule \\ rw [])) \\ gvs [dec_clock_def] + \\ qexists `n' + n` + \\ simp [first_n_exps_shift_seq] + \\ qmatch_asmsub_abbrev_tac `mglobals_extend s0.globals g1 s1.globals` + \\ qmatch_asmsub_abbrev_tac `mglobals_extend s1.globals g2 s.globals` + \\ qmatch_goalsub_abbrev_tac `mglobals_extend s0.globals g3 s.globals` + \\ rfs [] + \\ `g1 ∪ g2 ⊆ g3` suffices_by + metis_tac [mglobals_extend_trans, mglobals_extend_SUBSET] + \\ unabbrev_all_tac + \\ rpt (pop_assum kall_tac) + \\ gvs [elist_globals_append, SET_OF_BAG_UNION, AppUnit_def, + op_gbag_def] + \\ metis_tac [UNION_ASSOC, UNION_COMM, SUBSET_UNION])) \\ reverse (fs [result_case_eq, pair_case_eq]) \\ rveq \\ fs [] \\ drule do_app_ssgc \\ fs [EVERY_REVERSE] \\ strip_tac \\ rveq \\ fs [] @@ -2107,41 +2196,121 @@ Proof THEN1 (irule state_globals_approx_known_op_evaluate \\ rpt (goal_assum drule \\ simp [])) - \\ reverse (Cases_on `opn = Install`) \\ fs [] + \\ reverse (Cases_on `opn = Install ∨ opn = ThunkOp ForceThunk`) \\ fs [] THEN1 (fs [result_case_eq, pair_case_eq] \\ rveq \\ fs [] THEN1 (irule known_op_correct_approx \\ rpt (goal_assum drule \\ simp [])) \\ irule state_globals_approx_known_op_evaluate \\ rpt (goal_assum drule \\ simp [])) - \\ fs [known_op_def] \\ rveq \\ rfs [] - \\ reverse (fs [result_case_eq, pair_case_eq]) \\ rveq \\ fs [] - THEN1 - (fs [do_install_def, case_eq_thms] \\ rveq \\ fs [] - \\ pairarg_tac \\ fs [] - \\ fs [bool_case_eq, pair_case_eq, case_eq_thms] \\ rveq \\ fs []) - \\ rename1 `do_install _ _ = (_, s2)` - \\ `?n. s.compile_oracle = shift_seq n s1.compile_oracle /\ - mglobals_extend s1.globals (SET_OF_BAG (elist_globals (FLAT (first_n_exps s1.compile_oracle n)))) s.globals` - by (drule evaluate_changed_globals - \\ drule do_install_ssgc - \\ last_assum (mp_then (Pos hd) mp_tac evaluate_changed_globals) - \\ simp [] \\ disch_then kall_tac \\ strip_tac \\ strip_tac - \\ goal_assum drule - \\ last_assum (mp_then (Pos hd) mp_tac mglobals_extend_trans) - \\ disch_then drule - \\ fs [first_n_exps_shift_seq, SET_OF_BAG_UNION, elist_globals_append]) - \\ `oracle_gapprox_disjoint g s1.compile_oracle` - by (irule oracle_gapprox_disjoint_lemma - \\ rpt (goal_assum drule \\ simp [])) - \\ pop_assum mp_tac \\ simp [oracle_gapprox_disjoint_first_n_exps] - \\ rw [state_globals_approx_def] - \\ first_x_assum (qspec_then `n` assume_tac) - \\ fs [gapprox_disjoint_def, DISJOINT_ALT, domain_lookup, PULL_EXISTS] - \\ pop_assum drule \\ strip_tac - \\ fs [mglobals_extend_def] - \\ first_x_assum drule \\ simp [] \\ strip_tac - \\ metis_tac [state_globals_approx_def]) + >~ [`Install`] >- ( + fs [known_op_def] \\ rveq \\ rfs [] + \\ reverse (fs [result_case_eq, pair_case_eq]) \\ rveq \\ fs [] + THEN1 + (fs [do_install_def, case_eq_thms] \\ rveq \\ fs [] + \\ pairarg_tac \\ fs [] + \\ fs [bool_case_eq, pair_case_eq, case_eq_thms] \\ rveq \\ fs []) + \\ rename1 `do_install _ _ = (_, s2)` + \\ `?n. s.compile_oracle = shift_seq n s1.compile_oracle /\ + mglobals_extend s1.globals (SET_OF_BAG (elist_globals (FLAT (first_n_exps s1.compile_oracle n)))) s.globals` + by (drule evaluate_changed_globals + \\ drule do_install_ssgc + \\ last_assum (mp_then (Pos hd) mp_tac evaluate_changed_globals) + \\ simp [] \\ disch_then kall_tac \\ strip_tac \\ strip_tac + \\ goal_assum drule + \\ last_assum (mp_then (Pos hd) mp_tac mglobals_extend_trans) + \\ disch_then drule + \\ fs [first_n_exps_shift_seq, SET_OF_BAG_UNION, elist_globals_append]) + \\ `oracle_gapprox_disjoint g s1.compile_oracle` + by (irule oracle_gapprox_disjoint_lemma + \\ rpt (goal_assum drule \\ simp [])) + \\ pop_assum mp_tac \\ simp [oracle_gapprox_disjoint_first_n_exps] + \\ rw [state_globals_approx_def] + \\ first_x_assum (qspec_then `n` assume_tac) + \\ fs [gapprox_disjoint_def, DISJOINT_ALT, domain_lookup, PULL_EXISTS] + \\ pop_assum drule \\ strip_tac + \\ fs [mglobals_extend_def] + \\ first_x_assum drule \\ simp [] \\ strip_tac + \\ metis_tac [state_globals_approx_def]) + >~ [`ThunkOp ForceThunk`] >- ( + gvs [known_op_def] + \\ gvs [oneline dest_thunk_def, AllCaseEqs()] + >- ( + `∃n. s.compile_oracle = shift_seq n s1.compile_oracle ∧ + mglobals_extend s1.globals (SET_OF_BAG (elist_globals (FLAT (first_n_exps s1.compile_oracle n)))) s.globals` + by ( + drule evaluate_changed_globals + \\ impl_tac >- ( + gvs [dec_clock_def, AppUnit_def] + \\ qpat_x_assum `evaluate (_,_,s0) = _` assume_tac + \\ drule evaluate_changed_globals \\ rw [] + \\ gvs [ssgc_free_def] + \\ first_x_assum drule \\ gvs []) + \\ rw [] + \\ goal_assum drule + \\ gvs [dec_clock_def, AppUnit_def, op_gbag_def]) + \\ `oracle_gapprox_disjoint g s1.compile_oracle` by ( + irule oracle_gapprox_disjoint_lemma + \\ rpt (goal_assum drule \\ simp [])) + \\ pop_assum mp_tac \\ simp [oracle_gapprox_disjoint_first_n_exps] + \\ rw [state_globals_approx_def] + \\ first_x_assum (qspec_then `n` assume_tac) + \\ fs [gapprox_disjoint_def, DISJOINT_ALT, domain_lookup, PULL_EXISTS] + \\ pop_assum drule \\ strip_tac + \\ fs [mglobals_extend_def] + \\ first_x_assum drule \\ simp [] \\ strip_tac + \\ metis_tac [state_globals_approx_def]) + >- ( + `∃n. s''.compile_oracle = shift_seq n s1.compile_oracle ∧ + mglobals_extend s1.globals (SET_OF_BAG (elist_globals (FLAT (first_n_exps s1.compile_oracle n)))) s''.globals` + by ( + drule evaluate_changed_globals + \\ impl_tac >- ( + gvs [dec_clock_def, AppUnit_def] + \\ qpat_x_assum `evaluate (_,_,s0) = _` assume_tac + \\ drule evaluate_changed_globals \\ rw [] + \\ gvs [ssgc_free_def] + \\ first_x_assum drule \\ gvs []) + \\ rw [] + \\ goal_assum drule + \\ gvs [dec_clock_def, AppUnit_def, op_gbag_def]) + \\ `oracle_gapprox_disjoint g s1.compile_oracle` by ( + irule oracle_gapprox_disjoint_lemma + \\ rpt (goal_assum drule \\ simp [])) + \\ pop_assum mp_tac \\ simp [oracle_gapprox_disjoint_first_n_exps] + \\ reverse $ rw [state_globals_approx_def] + >- (imp_res_tac evaluate_SING \\ gvs []) + \\ first_x_assum (qspec_then `n` assume_tac) + \\ fs [gapprox_disjoint_def, DISJOINT_ALT, domain_lookup, PULL_EXISTS] + \\ pop_assum drule \\ strip_tac + \\ fs [mglobals_extend_def] + \\ first_x_assum drule \\ simp [] \\ strip_tac + \\ metis_tac [state_globals_approx_def]) + >- ( + `∃n. s.compile_oracle = shift_seq n s1.compile_oracle ∧ + mglobals_extend s1.globals (SET_OF_BAG (elist_globals (FLAT (first_n_exps s1.compile_oracle n)))) s.globals` + by ( + drule evaluate_changed_globals + \\ impl_tac >- ( + gvs [dec_clock_def, AppUnit_def] + \\ qpat_x_assum `evaluate (_,_,s0) = _` assume_tac + \\ drule evaluate_changed_globals \\ rw [] + \\ gvs [ssgc_free_def] + \\ first_x_assum drule \\ gvs []) + \\ rw [] + \\ goal_assum drule + \\ gvs [dec_clock_def, AppUnit_def, op_gbag_def]) + \\ `oracle_gapprox_disjoint g s1.compile_oracle` by ( + irule oracle_gapprox_disjoint_lemma + \\ rpt (goal_assum drule \\ simp [])) + \\ pop_assum mp_tac \\ simp [oracle_gapprox_disjoint_first_n_exps] + \\ rw [state_globals_approx_def] + \\ first_x_assum (qspec_then `n` assume_tac) + \\ fs [gapprox_disjoint_def, DISJOINT_ALT, domain_lookup, PULL_EXISTS] + \\ pop_assum drule \\ strip_tac + \\ fs [mglobals_extend_def] + \\ first_x_assum drule \\ simp [] \\ strip_tac + \\ metis_tac [state_globals_approx_def]))) THEN1 (say "App" \\ rpt (pairarg_tac \\ fs []) \\ rveq @@ -2566,13 +2735,17 @@ Inductive ref_rel: (!bs. ref_rel c g (ByteArray bs) (ByteArray bs)) /\ (!xs ys. LIST_REL (v_rel c g) xs ys ==> - ref_rel c g (ValueArray xs) (ValueArray ys)) + ref_rel c g (ValueArray xs) (ValueArray ys)) /\ + (!m v w. + v_rel c g v w ==> + ref_rel c g (Thunk m v) (Thunk m w)) End Theorem ref_rel_simps[simp] = LIST_CONJ [ SIMP_CONV (srw_ss()) [ref_rel_cases] ``ref_rel c g (ValueArray vs) x``, - SIMP_CONV (srw_ss()) [ref_rel_cases] ``ref_rel c g (ByteArray bs) x``] + SIMP_CONV (srw_ss()) [ref_rel_cases] ``ref_rel c g (ByteArray bs) x``, + SIMP_CONV (srw_ss()) [ref_rel_cases] ``ref_rel c g (Thunk m v) x``] Theorem ref_rel_upd_inline_factor: ref_rel (c with inline_factor := k) = ref_rel c @@ -2646,7 +2819,7 @@ QED Theorem ref_rel_subspt: !c g r1 r2 g'. ref_rel c g r1 r2 /\ subspt g g' ==> ref_rel c g' r1 r2 Proof - Cases_on `r1` \\ rw [] \\ metis_tac [v_rel_LIST_REL_subspt] + Cases_on `r1` \\ rw [] \\ metis_tac [v_rel_LIST_REL_subspt, v_rel_subspt] QED Theorem state_rel_subspt: @@ -2954,6 +3127,41 @@ Proof \\ rw[] \\ metis_tac[]) QED +Triviality state_rel_opt_rel_refs: + (state_rel c g s1 s2 ∧ FLOOKUP s1.refs n = r1 ⇒ + ∃r2. FLOOKUP s2.refs n = r2 ∧ OPTREL (ref_rel c g) r1 r2) ∧ + (state_rel c g s1 s2 ∧ FLOOKUP s2.refs n = r2 ⇒ + ∃r1. FLOOKUP s1.refs n = r1 ∧ OPTREL (ref_rel c g) r1 r2) +Proof + rw [] \\ gvs [state_rel_def, fmap_rel_def, FLOOKUP_DEF] \\ rw [] +QED + +Triviality rel_update_thunk: + state_rel c g s1 s2 ∧ + LIST_REL (v_rel c g) vs ys ⇒ + (update_thunk [RefPtr v ptr] s1.refs vs = SOME refs1 ⇒ + ∃refs2. update_thunk [RefPtr v ptr] s2.refs ys = SOME refs2 ∧ + state_rel c g (s1 with refs := refs1) (s2 with refs := refs2)) +Proof + rw [] + \\ gvs [oneline update_thunk_def, AllCaseEqs()] \\ rw [] + \\ gvs [oneline dest_thunk_def, AllCaseEqs()] + \\ ( + gvs [oneline store_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ TRY ( + rename1 `FLOOKUP s2.refs pf = NONE ∨ _` + \\ qpat_x_assum `FLOOKUP s1.refs pf = _` assume_tac + \\ drule_all (cj 1 state_rel_opt_rel_refs) \\ rw [OPTREL_def] \\ gvs []) + \\ TRY ( + rename1 `FLOOKUP s2.refs ps = SOME _ ∧ _` + \\ qpat_x_assum `FLOOKUP s1.refs ps = _` assume_tac + \\ drule_all (cj 1 state_rel_opt_rel_refs) \\ rw [OPTREL_def] + \\ gvs []) + \\ gvs [state_rel_def, fmap_rel_def, FAPPLY_FUPDATE_THM] \\ rw [] + \\ metis_tac []) +QED + + val say = say0 "known_correct0"; Theorem known_correct0[local]: @@ -3511,6 +3719,186 @@ Proof elist_globals_append, BAG_ALL_DISTINCT_BAG_UNION])) THEN1 simp [compile_inc_upd_inline_factor, is_state_oracle_shift_imp] THEN1 fs [result_case_eq]) + \\ Cases_on `opn = ThunkOp ForceThunk` \\ gvs [] + >- ( + simp [isGlobal_def] + \\ irule_at (Pos hd) SmartOp_thm \\ simp [evaluate_def] + \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] + >- ( + `∃w. FLOOKUP t.refs ptr = SOME (Thunk Evaluated w) ∧ + v_rel c (next_g s) v w` by ( + gvs [state_rel_def, fmap_rel_def, FLOOKUP_DEF] + \\ first_x_assum drule \\ rw []) \\ gvs []) + >- ( + `∃w. FLOOKUP t.refs ptr = SOME (Thunk NotEvaluated w) ∧ + v_rel c (next_g s) f w` by ( + gvs [state_rel_def, fmap_rel_def, FLOOKUP_DEF] + \\ first_x_assum drule \\ rw []) \\ gvs [] + \\ `t.clock = 0` by gvs [state_rel_def] \\ gvs []) + >- ( + `∃w. FLOOKUP t.refs ptr = SOME (Thunk NotEvaluated w) ∧ + v_rel c (next_g s1) f w` by ( + gvs [state_rel_def, fmap_rel_def, FLOOKUP_DEF] + \\ first_x_assum drule \\ rw []) \\ gvs [PULL_EXISTS] + \\ simp [GSYM PULL_EXISTS] \\ rw [] + >- gvs [state_rel_def] + \\ gvs [PULL_EXISTS] + \\ `state_rel c (next_g (dec_clock 1 s1)) (dec_clock 1 s1) + (dec_clock 1 t)` + by gvs [state_rel_def, dec_clock_def, next_g_def] + \\ last_x_assum $ drule_at (Pat `state_rel _ _ _`) + \\ `known c [AppUnit (Var None 0)] [Other] g0 = + ([(AppUnit (Var None 0),Other)],g0)` + by ( + gvs [AppUnit_def, known_op_def, op_gbag_def] + \\ gvs [known_def] + \\ rpt (pairarg_tac \\ gvs [any_el_def, decide_inline_def]) + \\ gvs [known_op_def, isGlobal_def] + \\ gvs [clos_opTheory.SmartOp_def, clos_opTheory.SmartOp'_def]) + \\ gvs [] + \\ disch_then drule \\ gvs [] + \\ disch_then $ qspec_then `[f]` mp_tac \\ gvs [] + \\ disch_then $ qspecl_then [`[w]`, `[]`] mp_tac \\ gvs [] + \\ impl_tac >- ( + rw [] + >- gvs [AppUnit_def] + >- ( + qpat_x_assum `evaluate (_,_,s0) = _` assume_tac + \\ drule evaluate_IMP_shift_seq \\ rw [] + \\ gvs [co_every_Fn_vs_NONE_shift_seq]) + >- gvs [AppUnit_def, dec_clock_def, mglobals_disjoint_def, + op_gbag_def] + >- ( + qpat_x_assum `evaluate (_,_,s0) = _` assume_tac + \\ drule evaluate_IMP_shift_seq \\ rw [] + \\ gvs [oracle_gapprox_disjoint_shift_seq, dec_clock_def, next_g_def]) + >- gvs [dec_clock_def, state_oracle_mglobals_disjoint_def] + >- gvs [AppUnit_def] + >- ( + qpat_x_assum `evaluate (_,_,s0) = _` assume_tac + \\ drule evaluate_changed_globals \\ gvs []) + >- ( + qpat_x_assum `evaluate (_,_,s0) = _` assume_tac + \\ drule evaluate_changed_globals \\ rw [] \\ gvs [] + \\ gvs [ssgc_free_def] + \\ rpt (first_x_assum drule \\ rw [])) + >- ( + qpat_x_assum `evaluate (_,_,s0) = _` assume_tac + \\ drule evaluate_IMP_shift_seq \\ rw [] + \\ gvs [oracle_state_sgc_free_shift_seq]) + >- gvs [next_g_def] + >- ( + gvs [next_g_def, dec_clock_def] + \\ qpat_x_assum `evaluate (_,_,s0) = _` assume_tac + \\ drule evaluate_IMP_shift_seq \\ rw [] \\ gvs [] + \\ gvs [shift_seq_def] + \\ drule (iffLR oracle_gapprox_subspt_add) + \\ disch_then $ qspecl_then [`0`, `k`] assume_tac \\ gvs [] + \\ imp_res_tac subspt_trans) + >- ( + qpat_x_assum `evaluate (_,_,s0) = _` assume_tac + \\ drule evaluate_IMP_shift_seq \\ rw [] + \\ gvs [oracle_gapprox_subspt_shift_seq]) + >- ( + gvs [AppUnit_def, fv_max_def] \\ rw [] + \\ CCONTR_TAC + \\ qmatch_asmsub_abbrev_tac `fv1 v exp` + \\ `fv v [exp] ⇔ v = 0` by (unabbrev_all_tac \\ gvs [fv_def]) + \\ gvs []) + >- gvs [next_g_def] + >- ( + qpat_x_assum `evaluate (_,_,s0) = _` assume_tac + \\ drule evaluate_IMP_shift_seq \\ rw [] + \\ gvs [unique_set_globals_shift_seq, AppUnit_def, + unique_set_globals_def, op_gbag_def] \\ rw [] + \\ first_x_assum $ qspec_then `n + k` assume_tac \\ gvs [] + \\ qspecl_then [`s0.compile_oracle`, `n`, `k`] assume_tac + first_n_exps_shift_seq \\ gvs [] + \\ gvs [elist_globals_append, BAG_ALL_DISTINCT_BAG_UNION])) + \\ rw [] \\ gvs [] + \\ gvs [next_g_def] + \\ drule_all rel_update_thunk \\ rw []) + >- ( + `∃w. FLOOKUP t.refs ptr = SOME (Thunk NotEvaluated w) ∧ + v_rel c (next_g s1) f w` by ( + gvs [state_rel_def, fmap_rel_def, FLOOKUP_DEF] + \\ first_x_assum drule \\ rw []) \\ gvs [PULL_EXISTS] + \\ simp [GSYM PULL_EXISTS] \\ rw [] + \\ `t.clock ≠ 0` by gvs [state_rel_def] \\ gvs [PULL_EXISTS] + \\ `state_rel c (next_g (dec_clock 1 s1)) (dec_clock 1 s1) + (dec_clock 1 t)` + by gvs [state_rel_def, dec_clock_def, next_g_def] + \\ last_x_assum $ drule_at (Pat `state_rel _ _ _`) + \\ `known c [AppUnit (Var None 0)] [Other] g0 = + ([(AppUnit (Var None 0),Other)],g0)` + by ( + gvs [AppUnit_def, known_op_def, op_gbag_def] + \\ gvs [known_def] + \\ rpt (pairarg_tac \\ gvs [any_el_def, decide_inline_def]) + \\ gvs [known_op_def, isGlobal_def] + \\ gvs [clos_opTheory.SmartOp_def, clos_opTheory.SmartOp'_def]) + \\ gvs [] + \\ disch_then drule \\ gvs [] + \\ disch_then $ qspec_then `[f]` mp_tac \\ gvs [] + \\ disch_then $ qspecl_then [`[w]`, `[]`] mp_tac \\ gvs [] + \\ impl_tac >- ( + rw [] + >- gvs [AppUnit_def] + >- ( + qpat_x_assum `evaluate (_,_,s0) = _` assume_tac + \\ drule evaluate_IMP_shift_seq \\ rw [] + \\ gvs [co_every_Fn_vs_NONE_shift_seq]) + >- gvs [AppUnit_def, dec_clock_def, mglobals_disjoint_def, + op_gbag_def] + >- ( + qpat_x_assum `evaluate (_,_,s0) = _` assume_tac + \\ drule evaluate_IMP_shift_seq \\ rw [] + \\ gvs [oracle_gapprox_disjoint_shift_seq, dec_clock_def, next_g_def]) + >- gvs [dec_clock_def, state_oracle_mglobals_disjoint_def] + >- gvs [AppUnit_def] + >- ( + qpat_x_assum `evaluate (_,_,s0) = _` assume_tac + \\ drule evaluate_changed_globals \\ gvs []) + >- ( + qpat_x_assum `evaluate (_,_,s0) = _` assume_tac + \\ drule evaluate_changed_globals \\ rw [] \\ gvs [] + \\ gvs [ssgc_free_def] + \\ rpt (first_x_assum drule \\ rw [])) + >- ( + qpat_x_assum `evaluate (_,_,s0) = _` assume_tac + \\ drule evaluate_IMP_shift_seq \\ rw [] + \\ gvs [oracle_state_sgc_free_shift_seq]) + >- gvs [next_g_def] + >- ( + gvs [next_g_def, dec_clock_def] + \\ qpat_x_assum `evaluate (_,_,s0) = _` assume_tac + \\ drule evaluate_IMP_shift_seq \\ rw [] \\ gvs [] + \\ gvs [shift_seq_def] + \\ drule (iffLR oracle_gapprox_subspt_add) + \\ disch_then $ qspecl_then [`0`, `k`] assume_tac \\ gvs [] + \\ imp_res_tac subspt_trans) + >- ( + qpat_x_assum `evaluate (_,_,s0) = _` assume_tac + \\ drule evaluate_IMP_shift_seq \\ rw [] + \\ gvs [oracle_gapprox_subspt_shift_seq]) + >- ( + gvs [AppUnit_def, fv_max_def] \\ rw [] + \\ CCONTR_TAC + \\ qmatch_asmsub_abbrev_tac `fv1 v exp` + \\ `fv v [exp] ⇔ v = 0` by (unabbrev_all_tac \\ gvs [fv_def]) + \\ gvs []) + >- gvs [next_g_def] + >- ( + qpat_x_assum `evaluate (_,_,s0) = _` assume_tac + \\ drule evaluate_IMP_shift_seq \\ rw [] + \\ gvs [unique_set_globals_shift_seq, AppUnit_def, + unique_set_globals_def, op_gbag_def] \\ rw [] + \\ first_x_assum $ qspec_then `n + k` assume_tac \\ gvs [] + \\ qspecl_then [`s0.compile_oracle`, `n`, `k`] assume_tac + first_n_exps_shift_seq \\ gvs [] + \\ gvs [elist_globals_append, BAG_ALL_DISTINCT_BAG_UNION])) + \\ rw [] \\ gvs [] + \\ Cases_on `e` \\ Cases_on `e'` \\ gvs [])) \\ Cases_on `isGlobal opn /\ gO_destApx apx <> gO_None` THEN1 (fs [] diff --git a/compiler/backend/proofs/clos_letopProofScript.sml b/compiler/backend/proofs/clos_letopProofScript.sml index 70001cd1de..75dcf758d7 100644 --- a/compiler/backend/proofs/clos_letopProofScript.sml +++ b/compiler/backend/proofs/clos_letopProofScript.sml @@ -86,13 +86,22 @@ Theorem v_rel_simps[simp] = prove(``v_rel Unit x <=> x = Unit``, fs [closSemTheory.Unit_def,Once v_rel_cases])] +Definition opt_rel_def[simp]: + opt_rel f NONE NONE = T /\ + opt_rel f (SOME x) (SOME y) = f x y /\ + opt_rel f _ _ = F +End + (* state relation *) Inductive ref_rel: (!bs. ref_rel (ByteArray bs) (ByteArray bs)) /\ (!xs ys. LIST_REL v_rel xs ys ==> - ref_rel (ValueArray xs) (ValueArray ys)) + ref_rel (ValueArray xs) (ValueArray ys)) /\ + (!m v w. + v_rel v w ==> + ref_rel (Thunk m v) (Thunk m w)) End Definition FMAP_REL_def: @@ -308,6 +317,50 @@ val do_install_lemma = prove( \\ fs [simple_val_rel_def, simple_state_rel] \\ rw [] \\ fs [v_rel_cases] \\ EVAL_TAC \\ fs [FUN_EQ_THM]); +Triviality state_rel_opt_rel_refs: + (state_rel s1 s2 ∧ FLOOKUP s1.refs n = r1 ⇒ + ∃r2. FLOOKUP s2.refs n = r2 ∧ opt_rel ref_rel r1 r2) ∧ + (state_rel s1 s2 ∧ FLOOKUP s2.refs n = r2 ⇒ + ∃r1. FLOOKUP s1.refs n = r1 ∧ opt_rel ref_rel r1 r2) +Proof + rw [] \\ gvs [state_rel_def, FMAP_REL_def, FLOOKUP_DEF] \\ rw [] +QED + +Triviality state_rel_clocks_eqs: + state_rel s1 s2 ⇒ s1.clock = s2.clock +Proof + rw [state_rel_def, state_component_equality] +QED + +Triviality state_rel_dec_clock: + state_rel s1 s2 ⇒ state_rel (dec_clock 1 s1) (dec_clock 1 s2) +Proof + rw [state_rel_def, dec_clock_def, state_component_equality] +QED + +Triviality rel_update_thunk: + state_rel s1 s2 ∧ + LIST_REL v_rel vs ys ⇒ + (update_thunk [RefPtr v ptr] s1.refs vs = NONE ⇒ + update_thunk [RefPtr v ptr] s2.refs ys = NONE) ∧ + (update_thunk [RefPtr v ptr] s1.refs vs = SOME refs1 ⇒ + ∃refs2. update_thunk [RefPtr v ptr] s2.refs ys = SOME refs2 ∧ + state_rel (s1 with refs := refs1) (s2 with refs := refs2)) +Proof + rw [] + \\ gvs [oneline update_thunk_def, AllCaseEqs()] \\ rw [] + \\ gvs [oneline dest_thunk_def, AllCaseEqs()] + \\ ( + gvs [Once v_rel_cases, oneline store_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ rpt ( + imp_res_tac state_rel_opt_rel_refs \\ rw [] + \\ gvs [oneline opt_rel_def] + \\ FULL_CASE_TAC \\ gvs [] + \\ rgs [Once ref_rel_cases]) + \\ gvs [state_rel_def, FMAP_REL_def, FLOOKUP_UPDATE] \\ rw [] + \\ simp [Once ref_rel_cases]) +QED + (* evaluate_let_op *) Theorem evaluate_let_op: @@ -457,7 +510,19 @@ Proof \\ fs [] \\ CCONTR_TAC \\ fs []) - (* op <> Install *) + \\ IF_CASES_TAC \\ rveq \\ fs [] + THEN1 (* Op = ThunkOp ForceThunk *) + (gvs [oneline dest_thunk_def, AllCaseEqs()] + \\ imp_res_tac (cj 1 state_rel_opt_rel_refs) + \\ qpat_x_assum `opt_rel ref_rel _ _` mp_tac + \\ simp [oneline opt_rel_def] \\ CASE_TAC \\ gvs [PULL_EXISTS] + \\ rgs [Once ref_rel_cases] + \\ imp_res_tac state_rel_clocks_eqs \\ gvs [PULL_EXISTS] + \\ imp_res_tac state_rel_dec_clock \\ gvs [] + \\ last_x_assum drule_all \\ rw [AppUnit_def, let_op_def] + \\ goal_assum drule \\ rw [] + \\ drule_all rel_update_thunk \\ rw []) + (* op <> Install /\ op <> ThunkOp ForceThunk *) \\ drule EVERY2_REVERSE \\ disch_tac \\ drule (GEN_ALL do_app_lemma) \\ disch_then drule diff --git a/compiler/backend/proofs/clos_mtiProofScript.sml b/compiler/backend/proofs/clos_mtiProofScript.sml index 0975ba71da..1d539635bc 100644 --- a/compiler/backend/proofs/clos_mtiProofScript.sml +++ b/compiler/backend/proofs/clos_mtiProofScript.sml @@ -117,9 +117,18 @@ Inductive ref_rel: (!bs. ref_rel max_app (ByteArray bs) (ByteArray bs)) /\ (!xs ys. LIST_REL (v_rel max_app) xs ys ==> - ref_rel max_app (ValueArray xs) (ValueArray ys)) + ref_rel max_app (ValueArray xs) (ValueArray ys)) /\ + (!m v w. + v_rel max_app v w ==> + ref_rel max_app (Thunk m v) (Thunk m w)) End +Theorem ref_rel_simps[simp] = + LIST_CONJ [ + SIMP_CONV (srw_ss()) [ref_rel_cases] ``ref_rel max_app (ValueArray vs) x``, + SIMP_CONV (srw_ss()) [ref_rel_cases] ``ref_rel max_app (ByteArray bs) x``, + SIMP_CONV (srw_ss()) [ref_rel_cases] ``ref_rel max_app (Thunk m v) x``] + Definition FMAP_REL_def: FMAP_REL r f1 f2 <=> FDOM f1 = FDOM f2 /\ @@ -149,6 +158,18 @@ Definition state_rel_def: t.compile_oracle = pure_co (clos_mti$compile_inc s.max_app) o s.compile_oracle End +Triviality state_rel_max_app: + state_rel s t ⇒ s.max_app = t.max_app ∧ 1 ≤ t.max_app +Proof + gvs [state_rel_def] +QED + +Triviality state_rel_clocks: + state_rel s t ⇒ s.clock = t.clock +Proof + gvs [state_rel_def] +QED + (* evaluation theorem *) Theorem collect_args_IMP: @@ -484,12 +505,51 @@ Proof (Cases_on `s'.refs ' ptr` \\ fs [] \\ Cases_on `t.refs ' ptr` \\ fs [ref_rel_cases] \\ fs [] \\ rveq \\ fs []) + THEN1 + (Cases_on `s'.refs ' ptr` \\ fs [] + \\ Cases_on `t.refs ' ptr` \\ fs [ref_rel_cases] + \\ fs [] \\ rveq \\ fs []) THEN (rpt gen_tac \\ Cases_on `k = p` \\ fs [] - THEN1 (fs [ref_rel_cases]) \\ fs [FAPPLY_FUPDATE_THM]) QED +Triviality state_rel_opt_rel_refs: + (state_rel s1 s2 ∧ FLOOKUP s1.refs n = r1 ⇒ + ∃r2. FLOOKUP s2.refs n = r2 ∧ OPTREL (ref_rel s1.max_app) r1 r2) ∧ + (state_rel s1 s2 ∧ FLOOKUP s2.refs n = r2 ⇒ + ∃r1. FLOOKUP s1.refs n = r1 ∧ OPTREL (ref_rel s1.max_app) r1 r2) +Proof + rw [] \\ gvs [state_rel_def, FMAP_REL_def, FLOOKUP_DEF] \\ rw [] +QED + +Triviality rel_update_thunk: + state_rel s1 s2 ∧ + LIST_REL (v_rel s1.max_app) vs ys ⇒ + (update_thunk [RefPtr v ptr] s2.refs ys = NONE ⇒ + update_thunk [RefPtr v ptr] s1.refs vs = NONE) ∧ + (update_thunk [RefPtr v ptr] s2.refs ys = SOME refs2 ⇒ + ∃refs1. update_thunk [RefPtr v ptr] s1.refs vs = SOME refs1 ∧ + state_rel (s1 with refs := refs1) (s2 with refs := refs2)) +Proof + rw [] + \\ gvs [oneline update_thunk_def, AllCaseEqs()] \\ rw [] + \\ gvs [oneline dest_thunk_def, AllCaseEqs()] + \\ ( + gvs [Once v_rel_cases, oneline store_thunk_def, AllCaseEqs()] + \\ TRY ( + drule_all (cj 2 state_rel_opt_rel_refs) \\ rw [OPTREL_def] + \\ rgs [Once ref_rel_cases]) + \\ TRY ( + drule (cj 1 state_rel_opt_rel_refs) \\ strip_tac + \\ first_x_assum dxrule \\ rw [OPTREL_def] \\ gvs [] + \\ imp_res_tac (cj 2 state_rel_opt_rel_refs) \\ gvs [OPTREL_def] + \\ rgs [Once ref_rel_cases]) + \\ gvs [state_rel_def, FMAP_REL_def, FLOOKUP_UPDATE] \\ rw [] + \\ simp [ref_rel_def] + \\ metis_tac []) +QED + val do_app_inst = simple_val_rel_do_app_rev |> Q.INST [`vr`|->`v_rel s.max_app`] @@ -709,6 +769,29 @@ Proof \\ fs [] \\ CCONTR_TAC \\ fs []) + \\ Cases_on `opp = ThunkOp ForceThunk` \\ gvs [] \\ rveq + >- ( + Cases_on `res1` \\ gvs [] + \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ drule_all (cj 2 state_rel_opt_rel_refs) \\ rw [OPTREL_def] + \\ rgs [Once ref_rel_cases] + \\ imp_res_tac evaluate_const \\ gvs [] + \\ imp_res_tac state_rel_clocks \\ gvs [PULL_EXISTS] + \\ ( + `state_rel (dec_clock 1 s2) (dec_clock 1 s')` by ( + gvs [state_rel_def, dec_clock_def]) \\ gvs [] + \\ last_x_assum $ drule_at (Pat `state_rel _ _`) \\ gvs [] + \\ disch_then $ qspecl_then [`[AppUnit (Var None 0)]`, `v`] mp_tac + \\ gvs [] \\ impl_tac + >- gvs [state_rel_def, dec_clock_def, AppUnit_def, no_mti_def, + intro_multi_def, collect_apps_def] + \\ rw [] \\ gvs [] + \\ gvs [dec_clock_def] + \\ Cases_on `res1` \\ gvs [] + \\ imp_res_tac state_rel_max_app \\ gvs [] + \\ drule rel_update_thunk \\ gvs [] + \\ disch_then drule \\ rw [] \\ gvs [] + \\ qrefine `Rval _` \\ gvs [PULL_EXISTS])) (* do_app *) \\ Cases_on `res1` \\ fs [] \\ imp_res_tac evaluate_const \\ fs [] @@ -1236,6 +1319,9 @@ Proof ONCE_REWRITE_TAC[contains_App_SOME_EXISTS] >> srw_tac[QUANT_INST_ss[pair_default_qp]][] >> metis_tac[contains_App_SOME_collect_args,SND,PAIR]) + >- ( + Cases_on `op` >> simp [contains_App_SOME_def] >> + Cases_on `t'` >> simp [contains_App_SOME_def]) QED Theorem contains_App_SOME_compile[simp]: @@ -1321,7 +1407,8 @@ Theorem collect_apps_preserves_set_globals: Proof ho_match_mp_tac clos_mtiTheory.collect_apps_ind >> simp[clos_mtiTheory.collect_apps_def, bool_case_eq] >> rpt strip_tac - >- (pop_assum (assume_tac o SYM) >> fs[elist_globals_append] >> + >- (pop_assum (assume_tac o SYM) >> gvs[elist_globals_append] >> + last_x_assum $ qspecl_then [`es''`,`e'`] assume_tac >> gvs [] >> metis_tac[bagTheory.COMM_BAG_UNION, bagTheory.ASSOC_BAG_UNION]) >- (rveq >> simp[]) QED diff --git a/compiler/backend/proofs/clos_numberProofScript.sml b/compiler/backend/proofs/clos_numberProofScript.sml index e651de1dfa..c44093b062 100644 --- a/compiler/backend/proofs/clos_numberProofScript.sml +++ b/compiler/backend/proofs/clos_numberProofScript.sml @@ -455,8 +455,11 @@ Proof (`ref_rel (v_rel s.max_app) (s.refs ' ptr) (t.refs ' ptr)` by fs[] \\ rpt (qpat_x_assum `!x._` kall_tac) \\ rfs [] \\ Cases_on `s.refs ' ptr` \\ fs [ref_rel_def]) + THEN1 + (`ref_rel (v_rel s.max_app) (s.refs ' ptr) (t.refs ' ptr)` by fs[] + \\ rpt (qpat_x_assum `!x._` kall_tac) + \\ rfs [] \\ Cases_on `s.refs ' ptr` \\ fs [ref_rel_def]) \\ rpt gen_tac \\ fs [] \\ Cases_on `x = p` \\ fs [FAPPLY_FUPDATE_THM] - \\ metis_tac [] QED val do_app_inst = @@ -612,6 +615,26 @@ Proof simp[LIST_REL_EL_EQN] QED +Triviality rel_update_thunk: + state_rel s1 s2 ∧ + LIST_REL (v_rel s1.max_app) vs ys ∧ + update_thunk [RefPtr v ptr] s1.refs vs = SOME refs1 ⇒ + ∃refs2. update_thunk [RefPtr v ptr] s2.refs ys = SOME refs2 ∧ + state_rel (s1 with refs := refs1) (s2 with refs := refs2) +Proof + rw [] + \\ gvs [oneline update_thunk_def, AllCaseEqs()] \\ rw [] + \\ gvs [oneline dest_thunk_def, AllCaseEqs()] + \\ ( + gvs [Once v_rel_cases, oneline store_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ rpt ( + imp_res_tac state_rel_refs \\ gvs [fmap_rel_def, FLOOKUP_DEF] + \\ first_x_assum dxrule \\ rw [] \\ gvs []) + \\ gvs [state_rel_def, fmap_rel_def, FAPPLY_FUPDATE_THM] \\ rw [] + \\ simp [Once v_rel_cases] + \\ metis_tac []) +QED + (* val do_install_Rabort = prove( ``closSem$do_install xs s2 = (Rerr (Rabort a),s3) ==> @@ -741,7 +764,7 @@ Proof `r1 <> Rerr (Rabort Rtype_error)` by (strip_tac \\ fs []) \\ fs[] >> tac >> full_simp_tac(srw_ss())[] >> Cases_on`op = Install` >- ( - fs[] + gvs [contains_App_SOME_def] \\ first_x_assum drule \\ disch_then drule \\ disch_then(qspec_then`n`strip_assume_tac) \\ rfs[] @@ -794,6 +817,33 @@ Proof \\ fs [do_install_def,case_eq_thms,bool_case_eq,pair_case_eq] ) >> srw_tac[][] >> + Cases_on`op = ThunkOp ForceThunk` >- ( + gvs [contains_App_SOME_def] + \\ first_x_assum drule_all \\ rw [] + \\ pop_assum $ qspec_then `n` assume_tac \\ gvs [] + \\ Cases_on `res'` \\ Cases_on `r1` \\ gvs [] + \\ imp_res_tac state_rel_max_app \\ gvs [] + \\ imp_res_tac evaluate_const \\ gvs [] + \\ imp_res_tac state_rel_clock \\ gvs [] + \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ rgs [Once v_rel_cases] + \\ imp_res_tac state_rel_refs \\ gvs [fmap_rel_def, FLOOKUP_DEF] + \\ first_x_assum drule \\ rw [] \\ gvs [PULL_EXISTS] + \\ gvs [AppUnit_def, contains_App_SOME_def] + \\ `(dec_clock 1 s2').max_app = s2'.max_app` by ( + gvs [state_rel_def, dec_clock_def]) \\ gvs [] + \\ `state_rel (dec_clock 1 s2') (dec_clock 1 t2)` by ( + drule state_rel_with_clock \\ rw [dec_clock_def]) + \\ last_x_assum $ drule_all_then $ qspec_then `n` mp_tac + \\ rw [renumber_code_locs_def] + \\ goal_assum drule \\ rw [] + \\ imp_res_tac evaluate_const \\ gvs [] + \\ drule_at (Pos $ el 3) rel_update_thunk \\ gvs []) >> + srw_tac[][] >> + `¬contains_App_SOME s.max_app xs` by ( + Cases_on `op` \\ gvs [contains_App_SOME_def] + \\ Cases_on `t` \\ gvs [contains_App_SOME_def]) >> + gvs[] >> first_x_assum(fn th => first_assum(mp_tac o MATCH_MP (ONCE_REWRITE_RULE[GSYM AND_IMP_INTRO]th))) >> disch_then(fn th => first_assum(qspec_then`n`STRIP_ASSUME_TAC o MATCH_MP th)) >> rev_full_simp_tac(srw_ss())[] >> Cases_on `r1` \\ full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >> diff --git a/compiler/backend/proofs/clos_ticksProofScript.sml b/compiler/backend/proofs/clos_ticksProofScript.sml index 2cf7a45a21..554c36d78b 100644 --- a/compiler/backend/proofs/clos_ticksProofScript.sml +++ b/compiler/backend/proofs/clos_ticksProofScript.sml @@ -104,13 +104,23 @@ Theorem v_rel_simps[simp] = prove(``v_rel x Unit <=> x = Unit``, fs [closSemTheory.Unit_def,Once v_rel_cases])] + +Definition opt_rel_def[simp]: + opt_rel f NONE NONE = T /\ + opt_rel f (SOME x) (SOME y) = f x y /\ + opt_rel f _ _ = F +End + (* state relation *) Inductive ref_rel: (!bs. ref_rel (ByteArray bs) (ByteArray bs)) /\ (!xs ys. LIST_REL v_rel xs ys ==> - ref_rel (ValueArray xs) (ValueArray ys)) + ref_rel (ValueArray xs) (ValueArray ys)) /\ + (!m v w. + v_rel v w ==> + ref_rel (Thunk m v) (Thunk m w)) End Definition FMAP_REL_def: @@ -362,6 +372,50 @@ val v_rel_IMP_v_to_words = prove( ``v_rel x y ==> v_to_words y = v_to_words x``, metis_tac [simple_val_rel, closPropsTheory.simple_val_rel_v_to_words]); +Triviality state_rel_opt_rel_refs: + (state_rel s1 s2 ∧ FLOOKUP s1.refs n = r1 ⇒ + ∃r2. FLOOKUP s2.refs n = r2 ∧ opt_rel ref_rel r1 r2) ∧ + (state_rel s1 s2 ∧ FLOOKUP s2.refs n = r2 ⇒ + ∃r1. FLOOKUP s1.refs n = r1 ∧ opt_rel ref_rel r1 r2) +Proof + rw [] \\ gvs [state_rel_def, FMAP_REL_def, FLOOKUP_DEF] \\ rw [] +QED + +Triviality state_rel_clock_eqs: + state_rel s t ⇒ s.clock = t.clock +Proof + gvs [state_rel_def] +QED + +Triviality state_rel_dec_clock: + state_rel s1 s2 ⇒ state_rel (dec_clock 1 s1) (dec_clock 1 s2) +Proof + rw [state_rel_def, dec_clock_def, state_component_equality] +QED + +Triviality rel_update_thunk: + state_rel s1 s2 ∧ + LIST_REL v_rel vs ys ⇒ + (update_thunk [RefPtr v ptr] s2.refs ys = NONE ⇒ + update_thunk [RefPtr v ptr] s1.refs vs = NONE) ∧ + (update_thunk [RefPtr v ptr] s2.refs ys = SOME refs2 ⇒ + ∃refs1. update_thunk [RefPtr v ptr] s1.refs vs = SOME refs1 ∧ + state_rel (s1 with refs := refs1) (s2 with refs := refs2)) +Proof + rw [] + \\ gvs [oneline update_thunk_def, AllCaseEqs()] \\ rw [] + \\ gvs [oneline dest_thunk_def, AllCaseEqs()] + \\ ( + gvs [Once v_rel_cases, oneline store_thunk_def, AllCaseEqs()] + \\ rpt ( + imp_res_tac state_rel_opt_rel_refs \\ rw [] + \\ gvs [oneline opt_rel_def] + \\ FULL_CASE_TAC \\ gvs [] + \\ rgs [Once ref_rel_cases]) + \\ gvs [state_rel_def, FMAP_REL_def, FLOOKUP_UPDATE] \\ rw [] + \\ simp [Once ref_rel_cases]) +QED + Theorem evaluate_remove_ticks: (!ys env2 (t1:('c,'ffi) closSem$state) res2 t2 env1 s1 xs. (evaluate (ys,env2,t1) = (res2,t2)) /\ @@ -540,8 +594,9 @@ Proof \\ reverse (fs [case_eq_thms]) \\ rveq \\ Cases_on `res1` \\ fs [] THEN1 (qexists_tac `ck + LENGTH ts` \\ fs []) - \\ reverse (Cases_on `op = Install`) \\ fs [] \\ rveq - THEN1 (* op /= Install *) + \\ reverse (Cases_on `op = Install ∨ op = ThunkOp ForceThunk`) + \\ fs [] \\ rveq + THEN1 (* op /= Install /\ op /= ForceThunk *) (fs [case_eq_thms] \\ rw [] \\ qexists_tac `ck + LENGTH ts` \\ fs [] \\ drule (GEN_ALL do_app_lemma) @@ -552,35 +607,58 @@ Proof \\ PairCases_on `v1` \\ fs [] \\ metis_tac []) - (* op = Install *) - \\ drule EVERY2_REVERSE \\ disch_tac - \\ drule (GEN_ALL do_install_lemma) - \\ disch_then drule - \\ fs [CaseEq "prod"] - \\ TOP_CASE_TAC - \\ reverse TOP_CASE_TAC + THEN1 (* op = Install *) + (drule EVERY2_REVERSE \\ disch_tac + \\ drule (GEN_ALL do_install_lemma) + \\ disch_then drule + \\ fs [CaseEq "prod"] + \\ TOP_CASE_TAC + \\ reverse TOP_CASE_TAC + >- ( + rw [] \\ qexists_tac`ck + LENGTH ts` \\ rw [] + \\ fs [] \\ rveq \\ fs [] \\ rfs [] + ) + \\ rw [] \\ fs [CaseEq "prod"] \\ rfs [] + \\ FIRST_X_ASSUM drule + \\ disch_then drule + \\ disch_then (drule o SIMP_RULE bool_ss [GSYM code_rel_def]) + \\ fs [code_rel_def] + \\ rw [] + \\ qexists_tac `ck' + ck + LENGTH ts` \\ rw[] + \\ imp_res_tac evaluate_clock + \\ imp_res_tac evaluate_add_clock \\ fs [] + \\ imp_res_tac do_install_add_to_clock + \\ imp_res_tac evaluate_length_imp + \\ fs [] + \\ CASE_TAC \\ fs [] \\ rveq \\ fs [] \\ rveq \\ fs [] + \\ irule LIST_REL_LAST + \\ rw [] + \\ CCONTR_TAC + \\ fs []) + (* op = ThunkOp ForceThunk *) + \\ gvs [PULL_FORALL] + \\ qrefine `ck' + ck + LENGTH ts` \\ gvs [] + \\ `∀ck'. evaluate (es,env1,s1 with clock := ck + (ck' + s1.clock)) = + (Rval a,s2 with clock := s2.clock + ck')` by ( + rw [] \\ drule evaluate_add_clock \\ gvs []) \\ gvs [] + \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ TRY (qexists `0` \\ gvs [state_rel_def] \\ NO_TAC) + \\ imp_res_tac (cj 2 state_rel_opt_rel_refs) + \\ qpat_x_assum `opt_rel ref_rel _ _` mp_tac + \\ simp [oneline opt_rel_def] \\ CASE_TAC \\ gvs [] + \\ rgs [Once ref_rel_cases] + \\ TRY (qexists `0` \\ gvs [state_rel_def] \\ NO_TAC) + \\ imp_res_tac state_rel_clock_eqs \\ gvs [PULL_EXISTS] + \\ imp_res_tac state_rel_dec_clock \\ gvs [] + \\ last_x_assum $ drule_then $ drule_then + $ qspec_then `[AppUnit (Var None 0)]` assume_tac + \\ gvs [AppUnit_def, remove_ticks_def, dec_clock_def] + \\ goal_assum drule \\ gvs [PULL_EXISTS] + \\ Cases_on `res1` \\ gvs [] + >- (drule_all rel_update_thunk \\ rw []) >- ( - rw [] \\ qexists_tac`ck + LENGTH ts` \\ rw [] - \\ fs [] \\ rveq \\ fs [] \\ rfs [] - ) - \\ rw [] \\ fs [CaseEq "prod"] \\ rfs [] - \\ FIRST_X_ASSUM drule - \\ disch_then drule - \\ disch_then (drule o SIMP_RULE bool_ss [GSYM code_rel_def]) - \\ fs [code_rel_def] - \\ rw [] - \\ qexists_tac `ck' + ck + LENGTH ts` \\ rw[] - \\ imp_res_tac evaluate_clock - \\ imp_res_tac evaluate_add_clock \\ fs [] - \\ imp_res_tac do_install_add_to_clock - \\ imp_res_tac evaluate_length_imp - \\ fs [] - \\ CASE_TAC \\ fs [] \\ rveq \\ fs [] \\ rveq \\ fs [] - \\ irule LIST_REL_LAST - \\ rw [] - \\ CCONTR_TAC - \\ fs [] - ) + qrefine `Rval _` \\ rw [PULL_EXISTS] + \\ drule_all rel_update_thunk \\ rw [])) THEN1 (* Fn *) (fs [LENGTH_EQ_NUM_compute] \\ rveq \\ fs [code_rel_def] diff --git a/compiler/backend/proofs/clos_to_bvlProofScript.sml b/compiler/backend/proofs/clos_to_bvlProofScript.sml index c48936d6d7..95499d2943 100644 --- a/compiler/backend/proofs/clos_to_bvlProofScript.sml +++ b/compiler/backend/proofs/clos_to_bvlProofScript.sml @@ -1516,7 +1516,8 @@ Proof QED fun cases_on_op q = Cases_on q >| - map (MAP_EVERY Cases_on) [[], [], [`i`], [`w`], [`b`], [`g`], [`m`], []]; + map (MAP_EVERY Cases_on) + [[`n`], [`s`], [`i`], [`w`], [`b`], [`g`], [`m`], [], [`t`]]; Theorem do_app[local]: (do_app op xs s1 = Rval (v,s2)) /\ @@ -1566,6 +1567,7 @@ Proof (srw_tac[][closSemTheory.do_app_def] \\ fs [] \\ every_case_tac \\ gvs [bvlSemTheory.do_app_def,v_rel_SIMP]) \\ Cases_on `op = Install` THEN1 fs[closSemTheory.do_app_def] + \\ Cases_on `∃t. op = ThunkOp t` THEN1 cheat \\ Cases_on `op = BlockOp Equal` THEN1 (srw_tac[][closSemTheory.do_app_def,bvlSemTheory.do_app_def, bvlSemTheory.do_eq_def] @@ -1809,7 +1811,7 @@ Proof \\ TRY (fs[case_eq_thms,bool_case_eq,v_case_eq_thms] \\ NO_TAC) \\ spose_not_then strip_assume_tac \\ fs[] \\ rpt (pop_assum mp_tac) - \\ rpt (PURE_CASE_TAC \\ fs []) \\ fs [] + \\ gvs [AllCaseEqs()] \\ TRY(rpt strip_tac \\ fs[v_rel_cases] \\ fs[state_rel_def] \\ NO_TAC) QED @@ -3933,6 +3935,7 @@ Proof \\ disj2_tac \\ CCONTR_TAC \\ fs [] ) \\ srw_tac[][] + \\ Cases_on `op = ThunkOp ForceThunk` THEN1 cheat \\ full_simp_tac(srw_ss())[cEval_def,compile_exps_def] \\ SRW_TAC [] [bEval_def] \\ `?p. evaluate (xs,env,s) = p` by full_simp_tac(srw_ss())[] \\ PairCases_on `p` \\ full_simp_tac(srw_ss())[] \\ `?cc. compile_exps s.max_app xs aux1 = cc` by full_simp_tac(srw_ss())[] \\ PairCases_on `cc` \\ full_simp_tac(srw_ss())[] diff --git a/compiler/backend/proofs/data_liveProofScript.sml b/compiler/backend/proofs/data_liveProofScript.sml index d9aed8db08..7bc0ace737 100644 --- a/compiler/backend/proofs/data_liveProofScript.sml +++ b/compiler/backend/proofs/data_liveProofScript.sml @@ -49,7 +49,8 @@ Proof QED fun cases_on_op q = Cases_on q >| - map (MAP_EVERY Cases_on) [[], [], [`i`], [`w`], [`b`], [`g`], [`m`], []]; + map (MAP_EVERY Cases_on) + [[`n`], [`s`], [`i`], [`w`], [`b`], [`g`], [`m`], [], [`t`]]; Triviality state_rel_IMP_do_app_aux: (do_app_aux op args s1 = Rval (v,s2)) /\ diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml index 4afe1cc254..d074cef386 100644 --- a/compiler/backend/proofs/data_to_wordProofScript.sml +++ b/compiler/backend/proofs/data_to_wordProofScript.sml @@ -1493,7 +1493,8 @@ Proof QED fun cases_on_op q = Cases_on q >| - map (MAP_EVERY Cases_on) [[], [], [`i`], [`w`], [`b`], [`g`], [`m`], []]; + map (MAP_EVERY Cases_on) + [[`n`], [`s`], [`i`], [`w`], [`b`], [`g`], [`m`], [], [`t`]]; Theorem data_to_word_lab_pres_lem: ∀c n l p. @@ -1642,7 +1643,8 @@ Proof QED fun cases_on_op q = Cases_on q >| - map (MAP_EVERY Cases_on) [[], [], [`i`], [`w`], [`b'`], [`g'`], [`m`], []]; + map (MAP_EVERY Cases_on) + [[`n`], [`s`], [`i`], [`w`], [`b`], [`g`], [`m`], [], [`t`]]; Theorem assign_no_inst[local]: ((a.has_longdiv ⇒ (ac.ISA = x86_64)) ∧ diff --git a/compiler/backend/proofs/data_to_word_assignProofScript.sml b/compiler/backend/proofs/data_to_word_assignProofScript.sml index 448e20d5d0..f94692cf6e 100644 --- a/compiler/backend/proofs/data_to_word_assignProofScript.sml +++ b/compiler/backend/proofs/data_to_word_assignProofScript.sml @@ -1957,7 +1957,8 @@ Proof QED fun cases_on_op q = Cases_on q >| - map (MAP_EVERY Cases_on) [[], [], [`i`], [`w`], [`b`], [`g`], [`m`], []]; + map (MAP_EVERY Cases_on) + [[`n`], [`s`], [`i`], [`w`], [`b`], [`g`], [`m`], [], [`t`]]; Theorem do_app_aux_safe_for_space_mono: (do_app_aux op xs s = Rval (r,s1)) /\ s1.safe_for_space ==> s.safe_for_space diff --git a/compiler/backend/proofs/flat_elimProofScript.sml b/compiler/backend/proofs/flat_elimProofScript.sml index 143945a06e..34d23b69d4 100644 --- a/compiler/backend/proofs/flat_elimProofScript.sml +++ b/compiler/backend/proofs/flat_elimProofScript.sml @@ -218,6 +218,8 @@ Definition find_refs_globals_def: union (find_v_globals a) (find_refs_globals t)) ∧ (find_refs_globals (Varray l::t) = union (find_v_globalsL l) (find_refs_globals t)) ∧ + (find_refs_globals (Thunk _ a::t) = + union (find_v_globals a) (find_refs_globals t)) ∧ (find_refs_globals (_::t) = find_refs_globals t) ∧ (find_refs_globals [] = LN) End @@ -230,10 +232,13 @@ Theorem find_refs_globals_MEM: ⇒ (∀ a . MEM (Refv a) refs ⇒ domain (find_v_globals a) ⊆ R) ∧ (∀ vs . MEM (Varray vs) refs - ⇒ domain (find_v_globalsL vs) ⊆ R) + ⇒ domain (find_v_globalsL vs) ⊆ R) ∧ + (∀ m a . MEM (Thunk m a) refs + ⇒ domain (find_v_globals a) ⊆ R) Proof Induct >> rw[] >> fs[find_refs_globals_def, domain_union] >> - Cases_on `h` >> fs[find_refs_globals_def, domain_union] + Cases_on `h` >> fs[find_refs_globals_def, domain_union] >> + first_x_assum drule >> gvs [] QED Theorem find_refs_globals_EL: @@ -241,7 +246,9 @@ Theorem find_refs_globals_EL: (∀ a . EL n refs = Refv a ⇒ domain (find_v_globals a) ⊆ R) ∧ (∀ vs . EL n refs = Varray vs - ⇒ domain (find_v_globalsL vs) ⊆ R) + ⇒ domain (find_v_globalsL vs) ⊆ R) ∧ + (∀ m a . EL n refs = Thunk m a + ⇒ domain (find_v_globals a) ⊆ R) Proof metis_tac [EL_MEM, find_refs_globals_MEM] QED @@ -257,7 +264,10 @@ Theorem find_refs_globals_LUPDATE: ⇒ domain (find_refs_globals (LUPDATE (Varray vs) n refs)) ⊆ domain reachable) ∧ (∀ ws. domain (find_refs_globals (LUPDATE (W8array ws) n refs)) - ⊆ domain reachable) + ⊆ domain reachable) ∧ + (∀ m a. domain (find_v_globals a) ⊆ domain reachable + ⇒ domain (find_refs_globals (LUPDATE (Thunk m a) n refs)) + ⊆ domain reachable) Proof Induct_on `refs` >> rw[] >> Cases_on `h` >> fs[find_refs_globals_def, domain_union] >> @@ -509,7 +519,6 @@ Theorem do_app_SOME_flat_state_rel: domain reachable ∧ EVERY ($~ ∘ v_has_Eval) (result_vs (evaluate$list_result result)) Proof - cheat (* rw [] \\ qpat_assum `flat_state_rel _ _ _` (mp_tac o REWRITE_RULE [flat_state_rel_def]) \\ rw [] @@ -629,7 +638,7 @@ Proof \\ fs [flat_state_rel_def, globals_rel_def, IS_SOME_EXISTS] \\ rfs [] \\ metis_tac [] - ) *) + ) QED @@ -746,7 +755,6 @@ Theorem evaluate_keep_flat_state_rel_eq_lemma: domain (find_sem_prim_res_globals result) ⊆ domain reachable ∧ EVERY (($~) ∘ v_has_Eval) (result_vs result)) Proof - cheat (* ho_match_mp_tac evaluate_exp_ind >> rpt CONJ_TAC >> rpt GEN_TAC >> TRY strip_tac >> TRY (simp [] >> NO_TAC) @@ -965,6 +973,55 @@ Proof ) ) >- ( + Cases_on `op = ThunkOp ForceThunk` >> gvs [] + >- ( + gvs [AllCaseEqs(), dec_clock_def, dest_GlobalVarLookup_def] + >- ( + gvs [oneline dest_thunk_def, AllCaseEqs(), + semanticPrimitivesTheory.store_lookup_def, flat_state_rel_def, + EVERY_EL] >> + first_x_assum drule >> gvs [] >> rw [] >> + gvs [find_sem_prim_res_globals_def, find_v_globals_def] >> + drule_all find_refs_globals_EL >> rw []) + >- gvs [oneline dest_thunk_def, AllCaseEqs(), + semanticPrimitivesTheory.store_lookup_def, flat_state_rel_def, + find_sem_prim_res_globals_def, find_result_globals_def] + >- ( + gvs [oneline dest_thunk_def, AllCaseEqs(), + semanticPrimitivesTheory.store_lookup_def, flat_state_rel_def] >> + simp [PULL_EXISTS] >> + last_x_assum $ qspecl_then + [`reachable`, `new_removed_state with clock := + new_removed_state.clock - 1`] mp_tac >> + impl_tac + >- ( + gvs [AppUnit_def, find_lookups_def, dest_GlobalVarLookup_def, + find_env_globals_def, find_v_globals_def, has_Eval_def, + EVERY_EL] >> + first_x_assum drule >> rw [] >> + drule_all find_refs_globals_EL >> rw []) >> + rw [] >> + goal_assum drule >> simp [] >> + gvs [oneline update_thunk_def, AllCaseEqs(), + semanticPrimitivesTheory.store_assign_def, + find_sem_prim_res_globals_def, find_v_globals_def] >> + rw [] + >- (drule_all find_refs_globals_LUPDATE >> gvs []) >> + gvs [EVERY_EL, EL_LUPDATE] >> rw []) + >- ( + gvs [oneline dest_thunk_def, AllCaseEqs(), + semanticPrimitivesTheory.store_lookup_def, flat_state_rel_def] >> + last_x_assum $ qspecl_then + [`reachable`, `new_removed_state with clock := + new_removed_state.clock - 1`] mp_tac >> + impl_tac + >- ( + gvs [AppUnit_def, find_lookups_def, dest_GlobalVarLookup_def, + find_env_globals_def, find_v_globals_def, has_Eval_def, + EVERY_EL] >> + first_x_assum drule >> rw [] >> + drule_all find_refs_globals_EL >> rw []) >> + rw [])) >> Cases_on `do_app q op (REVERSE a)` >> fs[] >> PairCases_on `x` >> fs[] >> rveq >> drule (GEN_ALL do_app_SOME_flat_state_rel) >> @@ -1063,7 +1120,7 @@ Proof fs [ELIM_UNCURRY, o_DEF, v_has_Eval_def, EVERY_MAP] >> simp [find_v_globals_MAP_Recclosure] >> rw [o_DEF] - ) *) + ) QED (******** EVALUATE SPECIALISATION ********) diff --git a/compiler/backend/proofs/flat_patternProofScript.sml b/compiler/backend/proofs/flat_patternProofScript.sml index ebc2cd88e5..59a6b01b1a 100644 --- a/compiler/backend/proofs/flat_patternProofScript.sml +++ b/compiler/backend/proofs/flat_patternProofScript.sml @@ -1593,7 +1593,6 @@ Theorem compile_exps_evaluate: state_rel s_cfg t1 t2 ) Proof - cheat (* ho_match_mp_tac evaluate_ind2 \\ simp [evaluate_decs_sing] \\ simp [evaluate_def, compile_exp_def, result_vs_def] @@ -1754,6 +1753,73 @@ Proof \\ fs [option_case_eq] \\ rveq \\ fs [] \\ rfs [env_rel_def, PULL_EXISTS, OPTREL_def] ) + \\ Cases_on `op = ThunkOp ForceThunk` + >- ( + gvs [AllCaseEqs(), dec_clock_def, PULL_EXISTS] + >- ( + gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS, + store_lookup_def] + \\ rgs [Once v_rel_cases] + \\ gvs [state_rel_def, LIST_REL_EL_EQN] + \\ `sv_rel v_rel (Thunk Evaluated v) (EL n t2.refs)` by ( + qpat_x_assum `∀n. n < LENGTH t2.refs ⇒ _` drule \\ rw []) + \\ gvs [] + \\ Cases_on `EL n t2.refs` \\ gvs []) + >- ( + gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS, + store_lookup_def] + \\ rgs [Once v_rel_cases] + \\ gvs [state_rel_def, LIST_REL_EL_EQN] + \\ qpat_x_assum `∀n. n < LENGTH t2.refs ⇒ _` drule \\ rw [] + \\ Cases_on `EL n t2.refs` \\ gvs []) + >- ( + gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS, + store_lookup_def] + \\ rgs [Once v_rel_cases] + \\ `∃a. EL n t2.refs = Thunk NotEvaluated a ∧ + v_rel f a` by ( + gvs [state_rel_def, LIST_REL_EL_EQN] + \\ qpat_x_assum `∀n. n < LENGTH t2.refs ⇒ _` drule \\ rw [] + \\ Cases_on `EL n t2.refs` \\ gvs []) \\ gvs [] + \\ simp [PULL_EXISTS] + \\ gvs [AppUnit_def, compile_exp_def, PULL_EXISTS, dec_name_to_num_def] + \\ last_x_assum $ qspecl_then [`1`, `<|v := [("f",a)]|>`, + `t2 with clock := t2.clock - 1`] mp_tac + \\ impl_tac + >- gvs [env_rel_def, ALOOKUP_rel_def, OPTREL_def, state_rel_def] + \\ rw [] \\ gvs [] + \\ gvs [oneline update_thunk_def, AllCaseEqs()] + \\ gvs [store_assign_def, store_v_same_type_def] + \\ gvs [state_rel_def, LIST_REL_EL_EQN, EL_LUPDATE] + \\ rw [] + >- ( + qpat_x_assum `v_rel v y` mp_tac + \\ gvs [oneline dest_thunk_def, AllCaseEqs()] + \\ rw [Once v_rel_cases] + \\ gvs [store_lookup_def] + \\ qpat_x_assum `∀n. n < LENGTH t2'.refs ⇒ _` + $ qspec_then `n'` assume_tac \\ gvs [] + \\ Cases_on `EL n' t2'.refs` \\ gvs []) + >- ( + first_x_assum drule \\ rw [] + \\ Cases_on `EL n s''.refs` \\ Cases_on `EL n t2'.refs` \\ gvs [])) + >- ( + gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS, + store_lookup_def] + \\ rgs [Once v_rel_cases] + \\ `∃a. EL n t2.refs = Thunk NotEvaluated a ∧ + v_rel f a` by ( + gvs [state_rel_def, LIST_REL_EL_EQN] + \\ qpat_x_assum `∀n. n < LENGTH t2.refs ⇒ _` drule \\ rw [] + \\ Cases_on `EL n t2.refs` \\ gvs []) \\ gvs [] + \\ gvs [AppUnit_def, compile_exp_def, PULL_EXISTS, dec_name_to_num_def] + \\ last_x_assum $ qspecl_then [`1`, `<|v := [("f",a)]|>`, + `t2 with clock := t2.clock - 1`] mp_tac + \\ impl_tac + >- gvs [env_rel_def, ALOOKUP_rel_def, OPTREL_def, state_rel_def] + \\ rw [] \\ gvs [] + \\ gvs [evaluate_def, do_opapp_def, AllCaseEqs()] + \\ gvs [state_rel_def, LIST_REL_EL_EQN])) \\ fs [option_case_eq, pair_case_eq] \\ rveq \\ fs [] \\ drule_then (drule_then drule) do_app_thm_REVERSE @@ -1902,7 +1968,7 @@ Proof \\ rveq \\ fs [] \\ rveq \\ fs [] ) \\ fs [] - ) *) + ) QED Theorem compile_decs_eval_sim: diff --git a/compiler/backend/proofs/flat_to_closProofScript.sml b/compiler/backend/proofs/flat_to_closProofScript.sml index 2e3e90d0d3..12f5ae97d4 100644 --- a/compiler/backend/proofs/flat_to_closProofScript.sml +++ b/compiler/backend/proofs/flat_to_closProofScript.sml @@ -76,20 +76,12 @@ Definition opt_rel_def[simp]: opt_rel f _ _ = F End -Definition thunk_mode_to_digit_def[simp]: - thunk_mode_to_digit NotEvaluated = 0 /\ - thunk_mode_to_digit Evaluated = 1 -End - Definition store_rel_def: store_rel refs t_refs = !i. if LENGTH refs <= i then FLOOKUP t_refs i = NONE else case EL i refs of | Refv v => (?x. FLOOKUP t_refs i = SOME (ValueArray [x]) /\ v_rel v x) - | Thunk m v => - (?x. FLOOKUP t_refs i = SOME (ValueArray [ - Block (thunk_mode_to_digit m) []; x]) /\ - v_rel v x) + | Thunk m v => (?x. FLOOKUP t_refs i = SOME (Thunk m x) /\ v_rel v x) | Varray vs => (?xs. FLOOKUP t_refs i = SOME (ValueArray xs) /\ LIST_REL v_rel vs xs) | W8array bs => FLOOKUP t_refs i = SOME (ByteArray bs) @@ -156,6 +148,15 @@ Proof \\ first_x_assum (qspec_then `i` mp_tac) \\ fs [] QED +Theorem lookup_thunk: + state_rel s1 t1 /\ store_lookup i s1.refs = SOME (Thunk m v) ==> + ?w. FLOOKUP t1.refs i = SOME (Thunk m w) /\ v_rel v w +Proof + gvs [state_rel_def,store_rel_def] \\ rw [] + \\ gvs [store_lookup_def] + \\ first_x_assum (qspec_then `i` mp_tac) \\ gvs [] +QED + Triviality env_rel_CONS_upd: env_rel (env with v updated_by f) m db /\ v_rel v1 v2 ==> env_rel (env with v updated_by (\xs. (n,v1) :: f xs)) (SOME n :: m) (v2 :: db) @@ -1265,7 +1266,41 @@ QED Theorem op_thunk: ∀th_op. op = ThunkOp th_op ==> ^op_goal Proof - cheat + rpt strip_tac \\ rveq + \\ gvs [flatSemTheory.do_app_def, compile_op_def, evaluate_def, do_app_def] + \\ Cases_on `vs` \\ gvs [] + \\ Cases_on `th_op` \\ gvs [] + >- ( + Cases_on `t'` \\ gvs [] + \\ pairarg_tac \\ gvs [] + \\ rw [] + >- ( + gvs [store_alloc_def] + \\ drule state_rel_LEAST \\ rw [] + \\ gvs [state_rel_def, store_rel_def] \\ rw [] + >- ( + gvs [FLOOKUP_UPDATE] + \\ last_x_assum $ qspec_then `i` assume_tac \\ gvs []) + \\ rw [EL_APPEND, FLOOKUP_UPDATE] \\ gvs [] + \\ last_x_assum $ qspec_then `i` assume_tac \\ gvs []) + >- (simp [Once v_rel_cases] \\ gvs [store_alloc_def, state_rel_LEAST])) + \\ gvs [AllCaseEqs(), PULL_EXISTS] + \\ qpat_x_assum `v_rel (Loc _ _) _` mp_tac + \\ rw [Once v_rel_cases] + \\ qpat_x_assum `store_assign _ _ _ = _` mp_tac + \\ simp [store_assign_def, store_v_same_type_def] + \\ ntac 2 CASE_TAC \\ rw [GSYM PULL_EXISTS] + >- ( + gvs [state_rel_def, store_rel_def] + \\ first_x_assum (qspec_then `lnum` mp_tac) \\ gvs [] \\ rw [] + \\ simp [SF SFY_ss]) + >- ( + gvs [state_rel_def, store_rel_def] + \\ rw [FLOOKUP_UPDATE, EL_LUPDATE] + >- (last_x_assum $ qspec_then `i` assume_tac \\ gvs []) + \\ CASE_TAC \\ rw [] + \\ last_x_assum $ qspec_then `i` assume_tac \\ gvs []) + >- simp [Once v_rel_cases, Unit_def, EVAL ``tuple_tag``] QED Theorem compile_op_correct: @@ -1389,6 +1424,40 @@ Proof \\ fs [LENGTH_EQ_NUM_compute] QED +Triviality rel_update_thunk: + state_rel s1 s2 ∧ + LIST_REL v_rel vs ys ⇒ + (update_thunk [Loc v ptr] s1.refs vs = SOME refs1 ⇒ + ∃refs2. update_thunk [RefPtr v ptr] s2.refs ys = SOME refs2 ∧ + state_rel (s1 with refs := refs1) (s2 with refs := refs2)) +Proof + rw [] + \\ gvs [oneline flatSemTheory.update_thunk_def, oneline update_thunk_def, + AllCaseEqs()] \\ rw [] + \\ gvs [store_assign_def, store_v_same_type_def] + \\ Cases_on `EL ptr s1.refs` \\ gvs [] + \\ Cases_on `t` \\ gvs [] + \\ `∃b. FLOOKUP s2.refs ptr = SOME (Thunk NotEvaluated b)` by ( + gvs [state_rel_def, store_rel_def] + \\ last_x_assum $ qspec_then `ptr` assume_tac \\ gvs []) + \\ gvs [oneline flatSemTheory.dest_thunk_def, oneline dest_thunk_def, + AllCaseEqs()] + \\ gvs [Once v_rel_cases, store_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ ( + gvs [state_rel_def, store_rel_def, FLOOKUP_UPDATE, EL_LUPDATE] \\ rw [] + \\ TRY ( + gvs [store_lookup_def] + \\ last_x_assum $ qspec_then `n` assume_tac \\ gvs [] + \\ NO_TAC) + >- ( + rename1 `FLOOKUP s2.refs idx = _` + \\ last_x_assum $ qspec_then `idx` assume_tac \\ gvs []) + >- (simp [Once v_rel_cases] \\ metis_tac []) + >- ( + rename1 `EL idx s1.refs` + \\ last_x_assum $ qspec_then `idx` assume_tac \\ gvs [])) +QED + Theorem compile_App: ^(get_goal "flatLang$App") Proof @@ -1400,7 +1469,22 @@ Proof \\ disch_then drule \\ impl_tac THEN1 (CCONTR_TAC \\ fs []) \\ strip_tac - \\ Cases_on `op = ThunkOp ForceThunk` >- cheat + \\ Cases_on `op = ThunkOp ForceThunk` >- ( + gvs [dest_nop_def, compile_op_def, evaluate_def, AllCaseEqs(), PULL_EXISTS] + \\ gvs [oneline flatSemTheory.dest_thunk_def, oneline dest_thunk_def, + AllCaseEqs(), PULL_EXISTS] + \\ rgs [Once v_rel_cases] + \\ drule_all lookup_thunk \\ rw [] \\ gvs [] + \\ imp_res_tac state_rel_IMP_clock \\ gvs [PULL_EXISTS] + \\ imp_res_tac state_rel_dec_clock + \\ last_x_assum $ drule_then $ qspecl_then [`[SOME "f"]`, `[w]`] mp_tac + \\ ( + impl_tac + >- gvs [env_rel_def, findi_def, flatSemTheory.AppUnit_def] + \\ rw [AppUnit_def, flatSemTheory.AppUnit_def, dest_nop_def, compile_op_def, + arg2_def, findi_def, SmartCons_def, compile_def] + \\ goal_assum drule \\ gvs [] + \\ drule_all rel_update_thunk \\ rw [])) \\ Cases_on `op = Opapp` \\ fs [] THEN1 (fs [compile_op_def,dest_nop_def] \\ rveq @@ -1883,7 +1967,8 @@ Proof QED val cases_op = Cases >| - map (MAP_EVERY Cases_on) [[], [], [`i`], [`w`], [`b`], [`g`], [`m`], []]; + map (MAP_EVERY Cases_on) + [[`n`], [`s`], [`i`], [`w`], [`b`], [`g`], [`m`], [], [`t`]]; Theorem clos_FINITE_BAG_set_globals[simp]: (∀e. FINITE_BAG (closProps$set_globals e)) ∧ @@ -2114,6 +2199,7 @@ Proof \\ simp ([CopyByteAw8_def, CopyByteStr_def] @ props_defs) \\ simp [arg1_def, arg2_def] \\ EVERY_CASE_TAC + \\ TRY (Cases_on `t'` \\ gvs []) \\ fs props_defs \\ imp_res_tac EVERY_IMP_HD \\ fs [NULL_LENGTH, EVERY_REVERSE] diff --git a/compiler/backend/proofs/source_evalProofScript.sml b/compiler/backend/proofs/source_evalProofScript.sml index 7354d14160..495aa06019 100644 --- a/compiler/backend/proofs/source_evalProofScript.sml +++ b/compiler/backend/proofs/source_evalProofScript.sml @@ -622,13 +622,23 @@ Theorem do_app_sim: LIST_REL (sv_rel (v_rel es)) refs refs' /\ result_rel (v_rel es) (v_rel es) r r' Proof - cheat (* rw [s_rel_def] \\ fs [] \\ last_x_assum mp_tac \\ simp [Once do_app_cases] \\ rw [listTheory.SWAP_REVERSE_SYM] \\ fs [CaseEq "ffi_result", option_case_eq] \\ rveq \\ fs [] \\ simp [do_app_def] + >>~ [`thunk_op`] + >- gvs [thunk_op_def] + >- ( + gvs [AllCaseEqs(), thunk_op_def] + >- ( + rpt (pairarg_tac \\ gvs []) + \\ gvs [store_alloc_def, LIST_REL_EL_EQN]) + \\ drule_then (drule_then (qsubterm_then `store_assign _ _` mp_tac)) + store_assign + \\ rw [EVERY2_LUPDATE_same] + \\ gvs [LIST_REL_EL_EQN]) \\ simp [div_exn_v_def, sub_exn_v_def, chr_exn_v_def, EVERY2_refl, MEM_MAP, PULL_EXISTS] \\ TRY (drule_then imp_res_tac (CONJUNCT1 do_eq)) @@ -653,7 +663,7 @@ Proof \\ fs [LIST_REL_REPLICATE_same, EVERY2_LUPDATE_same, LIST_REL_APPEND_EQ] \\ TRY (Cases_on ‘ys’ using SNOC_CASES \\ gs[SNOC_APPEND, REVERSE_APPEND]) \\ TRY (fs [LIST_REL_EL_EQN, EVERY2_REVERSE1] \\ NO_TAC) - \\ imp_res_tac fpSemPropsTheory.fp_translate_cases \\ rveq \\ gs[] *) + \\ imp_res_tac fpSemPropsTheory.fp_translate_cases \\ rveq \\ gs[] QED Theorem pairarg_to_pair_map: @@ -966,10 +976,9 @@ val eval_simulation_setup = setup (` \\ rveq \\ fs [] ); -Triviality eval_simulation_App: +Theorem eval_simulation_App: ^(#get_goal eval_simulation_setup `Case ([App _ _])`) Proof - cheat (* rw [] \\ reverse (fs [pair_case_eq, result_case_eq] \\ rveq \\ fs []) \\ insts_tac @@ -1059,12 +1068,94 @@ Proof \\ TOP_CASE_TAC \\ gs[Boolv_def] \\ COND_CASES_TAC \\ gs[v_to_env_id_def]) \\ gs[shift_fp_opts_def, state_component_equality]) + >~ [`getOpClass op = Force`] + >- ( + gvs [AllCaseEqs(), dec_clock_def] + >- ( + gvs [oneline dest_thunk_def, AllCaseEqs(), oneline store_lookup_def] + \\ gvs [s_rel_def, LIST_REL_EL_EQN] + \\ `∃a. EL n refs'' = Thunk Evaluated a ∧ + v_rel orac_s'' v a` by ( + first_x_assum drule \\ rw [] + \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs [] + \\ simp [state_component_equality]) + >- ( + gvs [oneline dest_thunk_def, AllCaseEqs(), oneline store_lookup_def] + \\ gvs [s_rel_def, LIST_REL_EL_EQN] + \\ `∃a. EL n refs'' = Thunk NotEvaluated a ∧ + v_rel orac_s'' f a` by ( + first_x_assum drule \\ rw [] + \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs [] + \\ simp [state_component_equality]) + >- ( + gvs [oneline dest_thunk_def, AllCaseEqs(), oneline store_lookup_def] + \\ `n < LENGTH t''.refs ∧ + ∃a. EL n t''.refs = Thunk NotEvaluated a ∧ + v_rel (orac_s t''.eval_state) f a` by ( + gvs [s_rel_def, LIST_REL_EL_EQN] + \\ first_x_assum drule \\ rw [] + \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs [] + \\ drule_then assume_tac s_rel_clock \\ gvs [dec_clock_def] + \\ last_x_assum $ drule_then assume_tac + \\ pop_assum $ qspec_then `sing_env "f" a` assume_tac \\ gvs [] + \\ pop_assum mp_tac \\ impl_tac + >- ( + rw [env_rel_def, sing_env_def, namespaceTheory.nsEmpty_def] + \\ Cases_on `nm` + \\ gvs [namespaceTheory.nsLookup_def, namespaceTheory.nsBind_def]) + \\ rw [] \\ gvs [abort_def] + \\ simp [PULL_EXISTS] + \\ gvs [es_forward_def, es_stack_forward_def] + \\ gvs [oneline update_thunk_def, AllCaseEqs()] + \\ gvs [oneline store_assign_def] \\ rw [] + >- ( + gvs [oneline dest_thunk_def] + \\ qpat_x_assum `v_rel _ v y` mp_tac + \\ Cases_on `v` \\ Cases_on `y` \\ rw [Once v_rel_cases] + >- ( + gvs [oneline store_v_same_type_def] + \\ gvs [oneline store_lookup_def] + \\ gvs [s_rel_def, LIST_REL_EL_EQN] + \\ IF_CASES_TAC \\ gvs [] + \\ first_x_assum drule \\ rw [] + \\ Cases_on `EL n' st2.refs` \\ Cases_on `EL n' refs'4'` + \\ gvs [sv_rel_def] + \\ Cases_on `t` \\ gvs []) + >- gvs [v_to_env_id_def]) + >- gvs [s_rel_def, LIST_REL_EL_EQN] + >- ( + gvs [oneline store_v_same_type_def] + \\ gvs [s_rel_def, LIST_REL_EL_EQN] + \\ first_x_assum drule \\ rw [] + \\ Cases_on `EL n st2.refs` \\ Cases_on `EL n refs'4'` + \\ gvs [sv_rel_def]) + >- ( + gvs [s_rel_def, state_component_equality, LIST_REL_EL_EQN, EL_LUPDATE] + \\ rw [])) + >- ( + gvs [oneline dest_thunk_def, AllCaseEqs(), oneline store_lookup_def] + \\ `n < LENGTH t''.refs ∧ + ∃a. EL n t''.refs = Thunk NotEvaluated a ∧ + v_rel (orac_s t''.eval_state) f a` by ( + gvs [s_rel_def, LIST_REL_EL_EQN] + \\ first_x_assum drule \\ rw [] + \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs [] + \\ drule_then assume_tac s_rel_clock \\ gvs [dec_clock_def] + \\ last_x_assum $ drule_then assume_tac + \\ pop_assum $ qspec_then `sing_env "f" a` assume_tac \\ gvs [] + \\ pop_assum mp_tac \\ impl_tac + >- ( + rw [env_rel_def, sing_env_def, namespaceTheory.nsEmpty_def] + \\ Cases_on `nm` + \\ gvs [namespaceTheory.nsLookup_def, namespaceTheory.nsBind_def]) + \\ rw [] \\ gvs [abort_def] + \\ gvs [es_forward_def, es_stack_forward_def])) \\ eval_cases_tac \\ drule_then (drule_then assume_tac) do_app_sim \\ insts_tac \\ fs [s_rel_def] \\ rveq \\ fs [] \\ simp [state_component_equality] - \\ rw [] \\ fs [] *) + \\ rw [] \\ fs [] QED Triviality eval_simulation_Denv: @@ -1550,7 +1641,6 @@ Theorem evaluate_is_record_forward: recorded_orac_wf (ci_comp ci) (orac_s s'.eval_state).oracle) ) Proof - cheat (* then_select_goals [``Case [App _ _]``] ( ho_match_mp_tac (name_ind_cases [] full_evaluate_ind) \\ rpt conj_tac @@ -1562,6 +1652,12 @@ Proof \\ simp [record_forward_refl] >- ( Cases_on ‘getOpClass op’ \\ fs[] + >~ [`getOpClass op = Force`] >- ( + full_simp_tac bool_ss [do_eval_res_def, bool_case_eq, pair_case_eq, + option_case_eq, result_case_eq, dec_clock_def] + \\ rveq \\ full_simp_tac bool_ss [PAIR_EQ] + \\ gvs [AllCaseEqs()] + \\ imp_res_tac record_forward_trans_sym) \\ full_simp_tac bool_ss [do_eval_res_def, bool_case_eq, pair_case_eq, option_case_eq, result_case_eq, dec_clock_def] \\ rveq \\ full_simp_tac bool_ss [PAIR_EQ] @@ -1585,7 +1681,7 @@ Proof \\ eval_cases_tac \\ fs [Q.ISPEC `(a, b)` EQ_SYM_EQ] \\ rpt (drule_then irule record_forward_trans_sym) - \\ simp [record_forward_refl] *) + \\ simp [record_forward_refl] QED val agrees_tac = (drule_then irule orac_agrees_backward) @@ -1654,7 +1750,6 @@ val insert_oracle_correct_setup = setup ( Triviality insert_oracle_correct_App: ^(#get_goal insert_oracle_correct_setup `Case (_, [App _ _])`) Proof - cheat (* rw [] \\ fs [pair_case_eq, result_case_eq] \\ rveq \\ fs [] \\ fs [bool_case_eq] \\ rveq \\ fs [] \\ Cases_on ‘getOpClass op’ \\ gs[] @@ -1691,8 +1786,15 @@ Proof \\ agrees_impl_tac \\ simp [] ) + >~ [`getOpClass op = Force`] >- ( + gvs [AllCaseEqs(), dec_clock_def] + \\ eval_cases_tac + \\ imp_res_simp_tac evaluate_is_record_forward + \\ imp_res_simp_tac insert_declare_env + \\ agrees_impl_tac + \\ simp []) \\ eval_cases_tac - \\ Cases_on ‘st'.fp_state.canOpt = FPScope fpValTree$Opt’ \\ gs[shift_fp_opts_def] *) + \\ Cases_on ‘st'.fp_state.canOpt = FPScope fpValTree$Opt’ \\ gs[shift_fp_opts_def] QED Triviality insert_oracle_correct_Denv: @@ -1797,7 +1899,6 @@ Theorem evaluate_record_suffix: record_forward s''.eval_state s'.eval_state )) Proof - cheat (* ho_match_mp_tac full_evaluate_ind \\ rpt conj_tac \\ rpt (gen_tac ORELSE disch_tac) @@ -1822,8 +1923,19 @@ Proof \\ drule_then irule record_forward_trans) \\ NO_TAC) \\ simp [combine_dec_result_def, shift_fp_opts_def] + >>~ [`getOpClass op = Force`] + >- ( + gvs [AllCaseEqs(), dec_clock_def] + \\ drule_then (drule_then assume_tac) less_sub_1_cases \\ gvs [] + \\ imp_res_simp_tac evaluate_is_record_forward \\ gvs []) + >- ( + gvs [AllCaseEqs(), dec_clock_def] + \\ imp_res_simp_tac evaluate_is_record_forward \\ gvs [] + >- (drule_then irule record_forward_trans \\ gvs []) + >- (drule_then irule record_forward_trans \\ gvs []) + >- (disj2_tac \\ drule_then irule record_forward_trans \\ gvs [])) \\ rename1 ‘st2.fp_state.canOpt = FpScope fpValTree$Opt’ - \\ Cases_on ‘st2.fp_state.canOpt = FpScope fpValTree$Opt’ \\ gs[shift_fp_opts_def] *) + \\ Cases_on ‘st2.fp_state.canOpt = FpScope fpValTree$Opt’ \\ gs[shift_fp_opts_def] QED (* Constructs the oracle from an evaluation by using the recorded @@ -2335,7 +2447,6 @@ Theorem adjust_oracle_evaluate: evaluate_decs (s_adjust_oracle ci (compile_decs o f) s) env ds = (s_adjust_oracle ci (compile_decs o f) s', res)) Proof - cheat (* disch_tac \\ ho_match_mp_tac (name_ind_cases [] full_evaluate_ind) \\ fs [full_evaluate_def] @@ -2349,12 +2460,12 @@ Proof fs [astTheory.op_class_case_eq] \\ fs [bool_case_eq, Q.ISPEC `(a, b)` EQ_SYM_EQ] \\ gvs [] + >~ [`getOpClass op = Force`] >- gvs [AllCaseEqs(), dec_clock_def] \\ fs [option_case_eq, pair_case_eq, bool_case_eq, result_case_eq] \\ insts_tac \\ fs [dec_clock_def] (* sigh @ fp cases *) - \\ rw [] \\ fs [shift_fp_opts_def] - ) + \\ rw [] \\ fs [shift_fp_opts_def]) (* Eval *) \\ fs [do_eval_res_def] \\ fs [pair_case_eq, result_case_eq, option_case_eq] \\ gvs [] @@ -2385,7 +2496,7 @@ Proof \\ fs [Q.ISPEC `(a, b)` EQ_SYM_EQ] \\ fs [Q.ISPEC `(a, b)` EQ_SYM_EQ, combine_dec_result_eq_Rerr] \\ try (drule_then drule declare_env_is_insert) - \\ fs [declare_env_adjust] *) + \\ fs [declare_env_adjust] QED Triviality adjust_oracle_ev_decs = diff --git a/compiler/backend/proofs/source_to_flatProofScript.sml b/compiler/backend/proofs/source_to_flatProofScript.sml index 02e5dbcc38..7fd2bac187 100644 --- a/compiler/backend/proofs/source_to_flatProofScript.sml +++ b/compiler/backend/proofs/source_to_flatProofScript.sml @@ -711,7 +711,11 @@ Inductive sv_rel: (!genv vs vs'. LIST_REL (v_rel genv) vs vs' ⇒ - sv_rel genv (Varray vs) (Varray vs')) + sv_rel genv (Varray vs) (Varray vs')) ∧ + (!genv m v v'. + v_rel genv v v' + ⇒ + sv_rel genv (Thunk m v) (Thunk m v')) End Triviality sv_rel_weak: @@ -985,7 +989,6 @@ val do_app = time Q.prove ( TAKE 1 s1_i1.refs = TAKE 1 s2_i1.refs ∧ result_rel v_rel genv r r_i1 ∧ do_app s1_i1 (astOp_to_flatOp op) vs_i1 = SOME (s2_i1, r_i1)`, - cheat (* rpt gen_tac >> Cases_on `s1` >> Cases_on `s1_i1.refs` >> simp [] >> @@ -1357,6 +1360,26 @@ val do_app = time Q.prove ( fsrw_tac[][] >> srw_tac[][markerTheory.Abbrev_def, EL_LUPDATE] >> srw_tac[][v_rel_lems] >> CCONTR_TAC >> rfs [] >> rveq >> fs []) + >- ((* ThunkOp *) + srw_tac[][semanticPrimitivesPropsTheory.do_app_cases, + flatSemTheory.do_app_def, thunk_op_def] >> + gvs[AllCaseEqs(), PULL_EXISTS] + >- ( + ntac 2 (pairarg_tac >> gvs[]) >> + gvs[store_alloc_def] >> + srw_tac[][sv_rel_cases, result_rel_cases, v_rel_eqns] >> + gvs[LIST_REL_EL_EQN]) + >- ( + gvs[store_assign_def, store_v_same_type_def] >> + Cases_on `EL lnum q` >> gvs[] >> Cases_on `t'` >> gvs[] >> + qpat_x_assum `v_rel _ (Loc _ _) y` mp_tac >> rw[Once v_rel_cases] >> + gvs [LIST_REL_EL_EQN, REWRITE_RULE [ADD1] LUPDATE_def, EL_LUPDATE] + >- (rw[] >> simp [Once sv_rel_cases]) + >- simp[Once result_rel_cases, Once v_rel_cases] + >- ( + rw[REWRITE_RULE [ADD1] EL] >> + first_x_assum drule >> gvs[] >> + CASE_TAC >> rw[Once sv_rel_cases]))) >- ((* ListAppend *) simp [semanticPrimitivesPropsTheory.do_app_cases, flatSemTheory.do_app_def] >> rw [] >> @@ -1384,7 +1407,7 @@ val do_app = time Q.prove ( \\ rw[sv_rel_cases, result_rel_cases, v_rel_eqns]) >- ((* Eval *) srw_tac[][semanticPrimitivesPropsTheory.do_app_cases, flatSemTheory.do_app_def] - ) *)); + )); Triviality find_recfun: !x funs e comp_map y t. @@ -4074,10 +4097,9 @@ Proof \\ fs [] QED -Triviality compile_correct_App: +Theorem compile_correct_App: ^(#get_goal compile_correct_setup `Case [App _ _]`) Proof - cheat (* rpt disch_tac \\ fs [pair_case_eq] \\ fs [] \\ first_x_assum (drule_then (drule_then drule)) @@ -4259,14 +4281,170 @@ Proof \\ fs [invariant_def, s_rel_cases] ) >> Cases_on ‘getOpClass op’ >> gs[] - >- (Cases_on ‘op’ >> gs[astTheory.getOpClass_def]) - >- (Cases_on ‘op’ >> gs[astTheory.getOpClass_def]) + >- ( + Cases_on ‘op’ >> gs[astTheory.getOpClass_def] >> + Cases_on ‘t'’ >> gvs[]) + >- ( + Cases_on ‘op’ >> gs[astTheory.getOpClass_def] >> + Cases_on ‘t'’ >> gvs[]) >~ [‘getOpClass op = Reals’] >- ( fs[s_rel_cases] >> ‘~ st'.fp_state.real_sem’ by (imp_res_tac fpSemPropsTheory.evaluate_fp_opts_inv >> gs[]) >> - gs[]) >> + gs[]) + >~ [‘getOpClass op = Force’] + >- ( + Cases_on ‘op’ >> gvs[astTheory.getOpClass_def] >> + Cases_on ‘t'’ >> gvs[] >> + gvs[AllCaseEqs(), dec_clock_def, PULL_EXISTS] >> rw[] + >- ( + gvs[astOp_to_flatOp_def, evaluate_def, compile_exps_reverse, + AllCaseEqs()] >> + qpat_x_assum `result_rel _ _ _ r_i1` mp_tac >> + rw[Once result_rel_cases] >> + gvs[oneline evaluateTheory.dest_thunk_def, AllCaseEqs()] >> + rgs[Once v_rel_cases] >> gvs[] >> + simp[dest_thunk_def, AllCaseEqs(), PULL_EXISTS] >> + gvs[store_lookup_def, s_rel_cases, LIST_REL_EL_EQN] >> + `n + 1 < LENGTH s'_i1.refs` by (Cases_on `s'_i1.refs` >> gvs[]) >> + gvs[] >> + `∃v''. EL n (TL s'_i1.refs) = Thunk Evaluated v'' ∧ + v_rel genv' v v''` by ( + first_x_assum drule >> gvs[] >> rw[Once sv_rel_cases]) >> + simp[REWRITE_RULE [ADD1] EL, Once result_rel_cases] >> + goal_assum drule >> rw[]) + >- ( + gvs[astOp_to_flatOp_def, evaluate_def, compile_exps_reverse, + AllCaseEqs()] >> + qpat_x_assum `result_rel _ _ _ r_i1` mp_tac >> + rw[Once result_rel_cases] >> + gvs[oneline evaluateTheory.dest_thunk_def, AllCaseEqs()] >> + rgs[Once v_rel_cases] >> gvs[] >> + simp[dest_thunk_def, AllCaseEqs(), PULL_EXISTS] >> + gvs[store_lookup_def, s_rel_cases, LIST_REL_EL_EQN] >> + `n + 1 < LENGTH s'_i1.refs` by (Cases_on `s'_i1.refs` >> gvs[]) >> + gvs[] >> + `∃v'. EL n (TL s'_i1.refs) = Thunk NotEvaluated v' ∧ + v_rel genv' f v'` by ( + first_x_assum drule >> gvs[] >> rw[Once sv_rel_cases]) >> + simp[REWRITE_RULE [ADD1] EL, Once result_rel_cases] >> + goal_assum drule >> rw[]) + >- ( + gvs[astOp_to_flatOp_def, evaluate_def, compile_exps_reverse, + AllCaseEqs()] >> + qpat_x_assum `result_rel _ _ _ r_i1` mp_tac >> + rw[Once result_rel_cases] >> + gvs[oneline evaluateTheory.dest_thunk_def, AllCaseEqs()] >> + rgs[Once v_rel_cases] >> gvs[] >> + simp[dest_thunk_def, AllCaseEqs(), PULL_EXISTS] >> + gvs[store_lookup_def, s_rel_cases, LIST_REL_EL_EQN] >> + `n + 1 < LENGTH s'_i1.refs` by (Cases_on `s'_i1.refs` >> gvs[]) >> + gvs[] >> + `∃v'. EL n (TL s'_i1.refs) = Thunk NotEvaluated v' ∧ + v_rel genv' f v'` by ( + first_x_assum drule >> gvs[] >> rw[Once sv_rel_cases]) >> + simp[REWRITE_RULE [ADD1] EL, Once result_rel_cases, PULL_EXISTS] >> + last_x_assum mp_tac >> + disch_then $ qspecl_then [ + `genv'`, `<|c := nsEmpty; v := nsSing "f" (Local None "f")|>`, + `<|v := [("f",v')]|>`, `dec_clock s'_i1`, `["f"]`, `t`, `[None]`, `gen`, + `idxs`] mp_tac >> + impl_tac + >- ( + gvs[invariant_def, evaluateTheory.dec_clock_def, dec_clock_def] >> + gvs[s_rel_cases] >> + gvs[env_all_rel_cases] >> rw[] >> + qexistsl [`nsBind "f" f nsEmpty`, `<|c := nsEmpty; v := nsEmpty|>`] >> + rw[evaluateTheory.sing_env_def] + >- (qexists `[("f",f)]` >> rw[]) + >- simp[Once v_rel_cases] + >- ntac 2 (simp[Once v_rel_cases])) >> + rw[] >> gvs[] >> + gvs[evaluateTheory.AppUnit_def, compile_exp_def, astOp_to_flatOp_def, + bind_locals_def, namespaceTheory.nsBindList_def, compile_var_def] >> + simp[AppUnit_def] >> + qpat_x_assum `result_rel _ _ (Rval _) _` mp_tac >> + rw[Once result_rel_cases] >> + gvs[oneline evaluateTheory.update_thunk_def, AllCaseEqs()] >> + simp[update_thunk_def] >> + `dest_thunk [y] s'_i1'.refs = NONE` by ( + qpat_x_assum `v_rel _ v y` mp_tac >> + Cases_on `v` >> Cases_on `y` >> + rw[Once v_rel_cases, dest_thunk_def, Boolv_def] >> + gvs[evaluateTheory.dest_thunk_def, store_lookup_def] >> rw[] >> + `n' < LENGTH (TL s'_i1'.refs)` by (Cases_on `s'_i1'.refs` >> gvs[]) >> + gvs[] >> + first_x_assum drule >> simp[REWRITE_RULE [ADD1] EL] >> + Cases_on `EL n' st2.refs` >> Cases_on `EL n' (TL s'_i1'.refs)` >> + rw[Once sv_rel_cases] >> gvs[] >> Cases_on `t'` >> gvs[]) >> gvs[] >> + Cases_on `s'_i1'.refs` >> gvs[] >> + qexists `genv'3'` >> gvs[] >> + imp_res_tac SUBMAP_TRANS >> gvs[] >> + imp_res_tac subglobals_trans >> gvs[] >> + gvs[store_assign_def, store_v_same_type_def, REWRITE_RULE [ADD1] EL] >> + rw[] + >- ( + first_x_assum drule >> + Cases_on `EL n st2.refs` >> Cases_on `EL n t'` >> gvs[] >> + rw[Once sv_rel_cases]) + >- rw[REWRITE_RULE [ADD1] LUPDATE_def] + >- rw[REWRITE_RULE [ADD1] LUPDATE_def] + >- ( + rw[REWRITE_RULE [ADD1] LUPDATE_def, EL_LUPDATE] >> + simp[Once sv_rel_cases]) + >- ( + rw[REWRITE_RULE [ADD1] LUPDATE_def] >> + gvs[invariant_def] >> + rw[REWRITE_RULE [ADD1] LUPDATE_def] >> + gvs[s_rel_cases, LIST_REL_EL_EQN] >> + rw[EL_LUPDATE] >> simp[Once sv_rel_cases]) + >- ( + gvs[evaluateTheory.dec_clock_def] >> + drule_then irule orac_forward_rel_trans >> gvs[])) + >- ( + gvs[astOp_to_flatOp_def, evaluate_def, compile_exps_reverse, + AllCaseEqs()] >> + qpat_x_assum `result_rel _ _ _ r_i1` mp_tac >> + rw[Once result_rel_cases] >> + gvs[oneline evaluateTheory.dest_thunk_def, AllCaseEqs()] >> + rgs[Once v_rel_cases] >> gvs[] >> + simp[dest_thunk_def, AllCaseEqs(), PULL_EXISTS] >> + gvs[store_lookup_def, s_rel_cases, LIST_REL_EL_EQN] >> + `n + 1 < LENGTH s'_i1.refs` by (Cases_on `s'_i1.refs` >> gvs[]) >> + gvs[] >> + `∃v'. EL n (TL s'_i1.refs) = Thunk NotEvaluated v' ∧ + v_rel genv' f v'` by ( + first_x_assum drule >> gvs[] >> rw[Once sv_rel_cases]) >> + simp[REWRITE_RULE [ADD1] EL, Once result_rel_cases, PULL_EXISTS] >> + last_x_assum mp_tac >> + disch_then $ qspecl_then [ + `genv'`, `<|c := nsEmpty; v := nsSing "f" (Local None "f")|>`, + `<|v := [("f",v')]|>`, `dec_clock s'_i1`, `["f"]`, `t`, `[None]`, `gen`, + `idxs`] mp_tac >> + impl_tac + >- ( + gvs[invariant_def, evaluateTheory.dec_clock_def, dec_clock_def] >> + gvs[s_rel_cases] >> + gvs[env_all_rel_cases] >> rw[] >> + qexistsl [`nsBind "f" f nsEmpty`, `<|c := nsEmpty; v := nsEmpty|>`] >> + rw[evaluateTheory.sing_env_def] + >- (qexists `[("f",f)]` >> rw[]) + >- simp[Once v_rel_cases] + >- ntac 2 (simp[Once v_rel_cases])) >> + rw[] >> gvs[] >> + gvs[evaluateTheory.AppUnit_def, compile_exp_def, astOp_to_flatOp_def, + bind_locals_def, namespaceTheory.nsBindList_def, compile_var_def] >> + simp[AppUnit_def] >> + qpat_x_assum `result_rel _ _ (Rerr _) _` mp_tac >> + rw[Once result_rel_cases] + >- ( + qexists `genv'3'` >> gvs[] >> + imp_res_tac SUBMAP_TRANS >> gvs[] >> + imp_res_tac subglobals_trans >> gvs[] >> + gvs[evaluateTheory.dec_clock_def] >> + imp_res_tac orac_forward_rel_trans) + >- metis_tac[])) >> fs [Q.ISPEC `(a, b)` EQ_SYM_EQ, option_case_eq, pair_case_eq] >> rw [] >> rveq >> fs [] >> @@ -4277,12 +4455,14 @@ Proof rpt (disch_then drule) >> (impl_tac >- fs [invariant_def, s_rel_cases]) >> rw [] >> - `astOp_to_flatOp op ≠ Opapp ∧ astOp_to_flatOp op ≠ Eval` + `astOp_to_flatOp op ≠ Opapp ∧ astOp_to_flatOp op ≠ Eval ∧ + astOp_to_flatOp op ≠ ThunkOp ForceThunk` by ( rw [astOp_to_flatOp_def] >> Cases_on `op` >> simp [] >> - fs []) >> + fs [astTheory.getOpClass_def] >> + Cases_on `t'` >> gvs []) >> fs [evaluate_def, compile_exps_reverse] >> imp_res_tac do_app_state_unchanged >> imp_res_tac do_app_const >> @@ -4293,7 +4473,7 @@ Proof fs [invariant_def, s_rel_cases] >> rpt (TOP_CASE_TAC >> gs[result_rel_cases, semanticPrimitivesTheory.Boolv_def, Boolv_def, v_rel_eqns]) >> TRY COND_CASES_TAC >> gs[] >> - simp[ Once v_rel_rules] *) + simp[ Once v_rel_rules] QED Triviality compile_correct_Scope: diff --git a/compiler/backend/semantics/closPropsScript.sml b/compiler/backend/semantics/closPropsScript.sml index d7e3a8c5ad..1d74f2a478 100644 --- a/compiler/backend/semantics/closPropsScript.sml +++ b/compiler/backend/semantics/closPropsScript.sml @@ -100,12 +100,14 @@ QED Definition ref_rel_def[simp]: (ref_rel R (ValueArray vs) (ValueArray ws) ⇔ LIST_REL R vs ws) ∧ (ref_rel R (ByteArray as) (ByteArray bs) ⇔ as = bs) ∧ + (ref_rel R (Thunk ma a) (Thunk mb b) ⇔ ma = mb ∧ R a b) ∧ (ref_rel _ _ _ = F) End Theorem ref_rel_simp[simp]: (ref_rel R (ValueArray vs) y ⇔ ∃ws. y = ValueArray ws ∧ LIST_REL R vs ws) ∧ - (ref_rel R (ByteArray bs) y ⇔ y = ByteArray bs) + (ref_rel R (ByteArray bs) y ⇔ y = ByteArray bs) ∧ + (ref_rel R (Thunk m a) y ⇔ ∃b. y = Thunk m b ∧ R a b) Proof Cases_on`y`>>simp[ref_rel_def] >> srw_tac[][EQ_IMP_THM] QED @@ -208,6 +210,9 @@ Definition contains_App_SOME_def: contains_App_SOME max_app [x1]) /\ (contains_App_SOME max_app [Tick _ x1] ⇔ contains_App_SOME max_app [x1]) /\ + (contains_App_SOME max_app [Op _ (ThunkOp ForceThunk) xs] ⇔ + max_app < 1 ∨ + contains_App_SOME max_app xs) /\ (contains_App_SOME max_app [Op _ op xs] ⇔ contains_App_SOME max_app xs) /\ (contains_App_SOME max_app [App _ loc_opt x1 x2] ⇔ @@ -976,6 +981,7 @@ Theorem EVERY_pure_correct = Q.prove(` >- (full_simp_tac (srw_ss() ++ ETA_ss) [] >> every_case_tac >> full_simp_tac(srw_ss())[]) >- (full_simp_tac(srw_ss())[] >> every_case_tac >> full_simp_tac(srw_ss())[]) >- (Cases_on`op=Install` >- fs[pure_op_def] >> + Cases_on `op = ThunkOp ForceThunk` >- fs[pure_op_def] >> fsrw_tac[ETA_ss][] \\ PURE_CASE_TAC \\ fs[] \\ PURE_CASE_TAC \\ fs[] @@ -1588,9 +1594,10 @@ Proof full_simp_tac(srw_ss())[LET_THM, semanticPrimitivesTheory.store_alloc_def, semanticPrimitivesTheory.store_lookup_def, - semanticPrimitivesTheory.store_assign_def,ffiTheory.call_FFI_def] >> - srw_tac[][] >> - fs [case_eq_thms] \\ rveq \\ fs [] + semanticPrimitivesTheory.store_assign_def,ffiTheory.call_FFI_def] + >>~- ([`ThunkOp _`], gvs [AllCaseEqs()]) + \\ srw_tac[][] + \\ fs [case_eq_thms] \\ rveq \\ fs [] \\ rpt (pop_assum (mp_tac o GSYM)) \\ fs [case_eq_thms] \\ rveq \\ fs [] \\ rw [] \\ rpt (pop_assum (mp_tac o GSYM)) \\ rw [] @@ -1760,6 +1767,7 @@ val tac = rveq >> fsrw_tac[ARITH_ss][AC ADD_ASSOC ADD_COMM] >> rveq >> fs[] >> + gvs[AppUnit_def] >> metis_tac[evaluate_io_events_mono,with_clock_ffi,FST,SND,IS_PREFIX_TRANS,lemma,Boolv_11,lemma2,lemma3] Theorem evaluate_add_to_clock_io_events_mono: @@ -1804,9 +1812,12 @@ Theorem evaluate_timeout_clocks0: Proof ho_match_mp_tac evaluate_ind >> rpt conj_tac >> dsimp[evaluate_def, case_eq_thms, pair_case_eq, bool_case_eq] >> - rw[] >> pop_assum mp_tac >> - simp_tac (srw_ss()) [do_install_def,case_eq_thms,bool_case_eq,pair_case_eq,UNCURRY,LET_THM] >> - rw[] >> fs [] + rw[] >> pop_assum mp_tac + >~ [`do_install`] >- ( + simp_tac (srw_ss()) [do_install_def,case_eq_thms,bool_case_eq,pair_case_eq,UNCURRY,LET_THM] >> + rw[] >> fs []) + >~ [`dest_thunk`] >- ( + gvs [oneline dest_thunk_def, AllCaseEqs()] \\ rw [] \\ gvs []) QED val _ = export_rewrites ["closLang.exp_size_def"] @@ -1938,6 +1949,7 @@ Definition ssgc_free_def: ssgc_free ^s ⇔ (∀n m e. FLOOKUP s.code n = SOME (m,e) ⇒ set_globals e = {||}) ∧ (∀n vl. FLOOKUP s.refs n = SOME (ValueArray vl) ⇒ EVERY vsgc_free vl) ∧ + (∀n m v. FLOOKUP s.refs n = SOME (Thunk m v) ⇒ vsgc_free v) ∧ (∀v. MEM (SOME v) s.globals ⇒ vsgc_free v) ∧ (∀n exp aux. SND (s.compile_oracle n) = (exp, aux) ⇒ EVERY esgc_free exp ∧ elist_globals (MAP (SND o SND) aux) = {||}) @@ -2050,6 +2062,11 @@ Definition simple_state_rel_def: ∃w1. FLOOKUP s.refs ptr = SOME (ValueArray w1) ∧ LIST_REL vr w1 w) /\ + (∀m v t s ptr. + FLOOKUP t.refs ptr = SOME (Thunk m v) ∧ sr s t ⇒ + ∃w. + FLOOKUP s.refs ptr = SOME (Thunk m w) ∧ + vr w v) /\ (!s t. sr s t ==> s.ffi = t.ffi /\ FDOM s.refs = FDOM t.refs /\ LIST_REL (OPTREL vr) s.globals t.globals) /\ (!f s t. @@ -2062,6 +2079,10 @@ Definition simple_state_rel_def: sr s t /\ LIST_REL vr xs ys ==> sr (s with refs := s.refs |+ (p,ValueArray xs)) (t with refs := t.refs |+ (p,ValueArray ys))) /\ + (!s t p m v w. + sr s t /\ vr v w ==> + sr (s with refs := s.refs |+ (p,Thunk m v)) + (t with refs := t.refs |+ (p,Thunk m w))) /\ (!s t xs ys. sr s t /\ LIST_REL (OPTREL vr) xs ys ==> sr (s with globals := xs) (t with globals := ys)) @@ -2090,12 +2111,18 @@ val simple_state_rel_update_bytes = prove( (t with refs := t.refs |+ (p,ByteArray bs))``, fs [simple_state_rel_def]); -val simple_state_rel_update = prove( +val simple_state_rel_update_values = prove( ``simple_state_rel vr sr /\ sr s t /\ LIST_REL vr xs ys ==> sr (s with refs := s.refs |+ (p,ValueArray xs)) (t with refs := t.refs |+ (p,ValueArray ys))``, fs [simple_state_rel_def]); +val simple_state_rel_update_thunks = prove( + ``simple_state_rel vr sr /\ sr s t /\ vr v w ==> + sr (s with refs := s.refs |+ (p,Thunk m v)) + (t with refs := t.refs |+ (p,Thunk m w))``, + fs [simple_state_rel_def]); + val simple_state_rel_update_globals = prove( ``simple_state_rel vr sr /\ sr s t /\ LIST_REL (OPTREL vr) xs ys ==> sr (s with globals := xs) (t with globals := ys)``, @@ -2217,6 +2244,8 @@ Theorem simple_state_rel_FLOOKUP_refs_IMP: | SOME (ByteArray bs) => FLOOKUP s.refs p = SOME (ByteArray bs) | SOME (ValueArray vs) => ?xs. FLOOKUP s.refs p = SOME (ValueArray xs) /\ LIST_REL vr xs vs + | SOME (Thunk m w) => + ?v. FLOOKUP s.refs p = SOME (Thunk m v) /\ vr v w Proof fs [simple_state_rel_def] \\ Cases_on `x` \\ rw [] \\ res_tac \\ fs [] \\ rename1 `_ = SOME yy` \\ Cases_on `yy` \\ fs [] @@ -2301,6 +2330,19 @@ Proof \\ rw [do_app_def, case_eq_thms, pair_case_eq, bool_case_eq, PULL_EXISTS] \\ TRY CASE_TAC \\ fs [] \\ rw [] \\ metis_tac [simple_val_rel_list, simple_val_rel_APPEND, vr_list_NONE]) + \\ Cases_on `?i. opp = ThunkOp i` + THEN1 + (Cases_on `do_app opp ys t` \\ fs[] \\ rveq \\ pop_assum mp_tac + \\ rw [do_app_def, case_eq_thms, pair_case_eq, bool_case_eq, PULL_EXISTS] + \\ gvs [AllCaseEqs(), PULL_EXISTS] + \\ gvs [simple_val_rel_def, Unit_def, AllCaseEqs(), PULL_EXISTS] + \\ rveq \\ fs [] + \\ `FDOM s.refs = FDOM t.refs` by fs [simple_state_rel_def] \\ fs [] + \\ drule (GEN_ALL simple_state_rel_FLOOKUP_refs_IMP) + \\ disch_then drule \\ disch_then imp_res_tac \\ fs [] + \\ TRY (res_tac \\ fs [isClos_cases] \\ NO_TAC) + \\ match_mp_tac (GEN_ALL simple_state_rel_update_thunks) + \\ asm_exists_tac \\ fs []) \\ Cases_on `(?n. opp = Label n) \/ (?i. opp = IntOp i) \/ (?w. opp = WordOp w) \/ opp = Install \/ (?b. opp = BlockOp b ∧ ( @@ -2433,7 +2475,7 @@ Proof \\ rfs [simple_val_rel_def] \\ rveq \\ fs [] \\ TRY (res_tac \\ fs [isClos_cases] \\ NO_TAC) \\ `FDOM s.refs = FDOM t.refs` by fs [simple_state_rel_def] \\ fs [] - \\ TRY (match_mp_tac (GEN_ALL simple_state_rel_update)) + \\ TRY (match_mp_tac (GEN_ALL simple_state_rel_update_values)) \\ TRY (match_mp_tac (GEN_ALL simple_state_rel_update_bytes)) \\ asm_exists_tac \\ fs [LIST_REL_REPLICATE_same]) \\ Cases_on `?m. opp = MemOp m ∧ (m = UpdateByte \/ m = Update) \/ ?n. opp = FFI n` THEN1 @@ -2453,7 +2495,7 @@ Proof \\ TRY (match_mp_tac (GEN_ALL simple_state_rel_update_ffi)) \\ TRY (asm_exists_tac \\ fs []) \\ TRY (match_mp_tac (GEN_ALL simple_state_rel_update_bytes)) - \\ TRY (match_mp_tac (GEN_ALL simple_state_rel_update)) + \\ TRY (match_mp_tac (GEN_ALL simple_state_rel_update_values)) \\ asm_exists_tac \\ fs [] \\ match_mp_tac EVERY2_LUPDATE_same \\ fs []) \\ Cases_on `?b. opp = MemOp (CopyByte b)` THEN1 @@ -3065,7 +3107,9 @@ Proof \\ imp_res_tac do_app_adj_orac_Rval \\ imp_res_tac do_app_adj_orac_Rerr \\ fs [adj_orac_rel_def] \\ fsrw_tac [SATISFY_ss] [] - ) + \\ gvs [AllCaseEqs(), AppUnit_def, dec_clock_def] + \\ rveq \\ fs[] + \\ fs [adj_orac_rel_def] \\ fsrw_tac [SATISFY_ss] []) \\ TRY ( fs[closSemTheory.evaluate_def, bool_case_eq, @@ -3245,6 +3289,18 @@ Proof \\ pop_assum (assume_tac o SPEC_ALL) \\ rfs [] QED +Triviality SUBMAP_refs_clocks_eqs: + SUBMAP_rel s1 s2 ⇒ s1.refs = s2.refs ∧ s1.clock = s2.clock +Proof + rw [SUBMAP_rel_def, state_component_equality] +QED + +Triviality SUBMAP_dec_clock: + SUBMAP_rel s1 s2 ⇒ SUBMAP_rel (dec_clock 1 s1) (dec_clock 1 s2) +Proof + rw [SUBMAP_rel_def, dec_clock_def, state_component_equality] +QED + Theorem evaluate_code_SUBMAP: (∀p x y (z1:('c, 'ffi)closSem$state) r s1 s2 (z2:('c,'ffi)closSem$state). p = (x,y,z1) ∧ @@ -3334,6 +3390,16 @@ Proof \\ fs[PULL_EXISTS] \\ res_tac \\ fs[] \\ NO_TAC ) + \\ Cases_on`op = ThunkOp ForceThunk` + \\ fs[CaseEq"prod",CaseEq"semanticPrimitives$result",PULL_EXISTS] + \\ rveq \\ fs[] + >- ( + gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ imp_res_tac SUBMAP_refs_clocks_eqs \\ gvs [PULL_EXISTS] + \\ imp_res_tac SUBMAP_dec_clock \\ gvs [] + \\ last_x_assum drule \\ rw [] + \\ goal_assum drule \\ rw [] + \\ gvs [SUBMAP_rel_def, state_component_equality]) \\ imp_res_tac do_app_SUBMAP_Rval \\ fs[] \\ imp_res_tac do_app_SUBMAP_Rerr diff --git a/compiler/backend/semantics/closSemScript.sml b/compiler/backend/semantics/closSemScript.sml index 455858d553..b77362d54e 100644 --- a/compiler/backend/semantics/closSemScript.sml +++ b/compiler/backend/semantics/closSemScript.sml @@ -11,6 +11,7 @@ val _ = new_theory"closSem" Datatype: ref = ValueArray ('a list) | ByteArray (word8 list) + | Thunk thunk_mode 'a End (* --- Semantics of ClosLang --- *) @@ -415,6 +416,17 @@ Definition do_app_def: | (IntOp (LessConstSmall n),[Number i]) => (if 0 <= i /\ i <= 1000000 /\ n < 1000000 then Rval (Boolv (i < &n),s) else Error) | (MemOp ConfigGC,[Number _; Number _]) => (Rval (Unit, s)) + | (ThunkOp th_op, vs) => + (case (th_op,vs) of + | (AllocThunk m, [v]) => + (let ptr = (LEAST ptr. ~(ptr IN FDOM s.refs)) in + Rval (RefPtr F ptr, s with refs := s.refs |+ (ptr,Thunk m v))) + | (UpdateThunk m, [RefPtr _ ptr; v]) => + (case FLOOKUP s.refs ptr of + | SOME (Thunk NotEvaluated _) => + Rval (Unit, s with refs := s.refs |+ (ptr,Thunk m v)) + | _ => Error) + | _ => Error) | _ => Error End @@ -545,7 +557,8 @@ Theorem case_eq_thms = LIST_CONJ ( closLangTheory.word_op_case_eq :: closLangTheory.block_op_case_eq :: closLangTheory.glob_op_case_eq :: - closLangTheory.mem_op_case_eq :: map CaseEq + closLangTheory.mem_op_case_eq :: + astTheory.thunk_op_case_eq :: map CaseEq ["list","option","v","ref", "result","error_result","eq_result","app_kind","word_size"]); @@ -563,6 +576,35 @@ Proof \\ pairarg_tac \\ gvs[case_eq_thms,pair_case_eq,bool_case_eq] QED +Definition dest_thunk_def: + dest_thunk [RefPtr _ ptr] refs = + (case FLOOKUP refs ptr of + | SOME (Thunk Evaluated v) => SOME (INL v) + | SOME (Thunk NotEvaluated v) => SOME (INR v) + | _ => NONE) ∧ + dest_thunk vs refs = NONE +End + +Definition store_thunk_def: + store_thunk ptr v refs = + case FLOOKUP refs ptr of + | SOME (Thunk NotEvaluated _) => SOME (refs |+ (ptr,v)) + | _ => NONE +End + +Definition update_thunk_def: + update_thunk [RefPtr _ ptr] refs [v] = + (if dest_thunk [v] refs = NONE then + store_thunk ptr (Thunk Evaluated v) refs + else + NONE) ∧ + update_thunk _ _ _ = NONE +End + +Definition AppUnit_def: + AppUnit x = closLang$App None NONE x [Op None (BlockOp (Cons 0)) []] +End + Definition evaluate_def[nocompute]: (evaluate ([],env:closSem$v list,^s) = (Rval [],s)) /\ (evaluate (x::y::xs,env,s) = @@ -603,6 +645,20 @@ Definition evaluate_def[nocompute]: | (Rval vs,s) => (Rval [LAST vs],s) | res => res) | (Rerr err,s) => (Rerr err,s)) + else if op = ThunkOp ForceThunk then + (case dest_thunk vs s.refs of + | NONE => (Rerr (Rabort Rtype_error),s) + | SOME (INL v) => (Rval [v],s) + | SOME (INR f) => + if s.clock = 0 then + (Rerr (Rabort Rtimeout_error),s) + else + case evaluate ([AppUnit (Var None 0)],[f],(dec_clock 1 s)) of + | (Rval vs2,s) => + (case update_thunk vs s.refs vs2 of + | NONE => (Rerr (Rabort Rtype_error),s) + | SOME refs => (Rval vs2,s with refs := refs)) + | (Rerr e,s) => (Rerr e,s)) else (case do_app op (REVERSE vs) s of | Rerr err => (Rerr err,s) diff --git a/compiler/backend/semantics/flatSemScript.sml b/compiler/backend/semantics/flatSemScript.sml index 45eec798b7..f8f645c619 100644 --- a/compiler/backend/semantics/flatSemScript.sml +++ b/compiler/backend/semantics/flatSemScript.sml @@ -696,7 +696,11 @@ Definition dest_thunk_def: End Definition update_thunk_def: - update_thunk [Loc _ n] st [v] = store_assign n (Thunk Evaluated v) st ∧ + update_thunk [Loc _ n] st [v] = + (if dest_thunk [v] st = NONE then + store_assign n (Thunk Evaluated v) st + else + NONE) ∧ update_thunk _ st _ = NONE End diff --git a/semantics/evaluateScript.sml b/semantics/evaluateScript.sml index 887b516001..94514bf7cc 100644 --- a/semantics/evaluateScript.sml +++ b/semantics/evaluateScript.sml @@ -65,7 +65,11 @@ Definition dest_thunk_def: End Definition update_thunk_def: - update_thunk [Loc _ n] st [v] = store_assign n (Thunk Evaluated v) st ∧ + update_thunk [Loc _ n] st [v] = + (if dest_thunk [v] st = NONE then + store_assign n (Thunk Evaluated v) st + else + NONE) ∧ update_thunk _ st _ = NONE End diff --git a/semantics/proofs/evaluatePropsScript.sml b/semantics/proofs/evaluatePropsScript.sml index ca8083384c..4b11117dc5 100644 --- a/semantics/proofs/evaluatePropsScript.sml +++ b/semantics/proofs/evaluatePropsScript.sml @@ -449,7 +449,15 @@ Proof is_clock_io_mono_do_app_simple]), CASE_TAC]) \\ ho_match_mp_tac is_clock_io_mono_check \\ gs[] \\ rpt strip_tac \\ res_tac \\ gs[dec_inc_clock]) - >- cheat (* Force *) + >- ( + gvs [AllCaseEqs()] + \\ step_tac + \\ fs[is_clock_io_mono_def, dec_clock_def] + \\ Cases_on `a` \\ gvs[update_thunk_def] + \\ Cases_on `h` \\ gvs[update_thunk_def] + \\ Cases_on `t` \\ gvs[update_thunk_def] + \\ Cases_on `a'` \\ gvs[update_thunk_def] + \\ Cases_on `t` \\ gvs[update_thunk_def, store_assign_def]) >- (assume_tac (SIMP_RULE std_ss [] is_clock_io_mono_do_app_simple) \\ fs[]) >- (assume_tac (SIMP_RULE std_ss [] is_clock_io_mono_do_app_icing) \\ gs[]) \\ assume_tac (SIMP_RULE std_ss [] is_clock_io_mono_do_app_real) \\ fs[]) @@ -894,7 +902,14 @@ Proof \\ strip_tac \\ fs [evaluate_case_eqs, dec_clock_def, do_eval_res_def, shift_fp_opts_def] >~ [‘op:op’] >- - (Cases_on ‘getOpClass op = Force’ >- cheat + (Cases_on ‘getOpClass op = Force’ >- + (gvs [] + \\ Cases_on `op` \\ gvs [] \\ Cases_on `t` \\ gvs [] + \\ gvs [AllCaseEqs()] + \\ imp_res_tac evaluate_next_type_stamp_mono + \\ imp_res_tac evaluate_next_exn_stamp_mono + \\ rw [] + \\ fs [build_tdefs_def]) \\ Cases_on ‘getOpClass op’ \\ fs [] \\ fs [evaluate_case_eqs, dec_clock_def, do_eval_res_def] \\ rveq \\ fs [] @@ -1062,7 +1077,16 @@ Proof `evaluate (dec_clock s2) _ _ = (s3, _)`] \\ fs[dec_clock_def] \\ by_eq) - >- cheat (* Force *) + >- ( + Cases_on `op` \\ gvs[] \\ Cases_on `t` \\ gvs[] + \\ gvs[AllCaseEqs(), dec_clock_def] + \\ rpt strip_tac \\ gvs[] \\ rveq + \\ imp_res_tac evaluate_fp_opts_inv \\ gvs[] + \\ gvs[state_component_equality,fpState_component_equality, FUN_EQ_THM] + \\ qpat_x_assum `∀x. q.fp_state.opts _ = _` $ gs o single o GSYM + \\ rename1 `sa.fp_state.choices ≤ q.fp_state.choices` + \\ ‘sa.fp_state.choices = q.fp_state.choices’ by gs[] + \\ pop_assum $ fs o single) >- ( ntac 2 (TOP_CASE_TAC \\ fs[]) >- (trivial) \\ ntac 2 (TOP_CASE_TAC \\ fs[]) @@ -1203,7 +1227,16 @@ Proof `evaluate (dec_clock s2) _ _ = (s3, _)`] \\ fs[dec_clock_def] \\ by_eq) - >- cheat (* Force *) + >- ( + Cases_on `op` \\ gvs[] \\ Cases_on `t` \\ gvs[] + \\ gvs [AllCaseEqs(), dec_clock_def] + \\ rpt strip_tac \\ gvs[] \\ rveq + \\ imp_res_tac evaluate_fp_opts_inv \\ gvs[] + \\ gvs[state_component_equality,fpState_component_equality, FUN_EQ_THM] + \\ qpat_x_assum `∀x. q.fp_state.opts _ = _` $ gs o single o GSYM + \\ rename1 `sa.fp_state.choices ≤ q.fp_state.choices` + \\ ‘sa.fp_state.choices = q.fp_state.choices’ by gs[] + \\ pop_assum $ fs o single) >- ( ntac 2 (TOP_CASE_TAC \\ fs[]) >- (trivial) \\ ntac 2 (TOP_CASE_TAC \\ fs[]) @@ -1362,7 +1395,16 @@ Proof `evaluate (dec_clock s2) _ _ = (s3, _)`] \\ fs[dec_clock_def] \\ by_eq) - >- cheat (* Force *) + >- ( + Cases_on `op` \\ gvs[] \\ Cases_on `t` \\ gvs[] + \\ gvs [AllCaseEqs(), dec_clock_def] + \\ rpt strip_tac \\ gvs[] \\ rveq + \\ imp_res_tac evaluate_fp_opts_inv \\ gvs[] + \\ gvs[state_component_equality,fpState_component_equality, FUN_EQ_THM] + \\ qpat_x_assum `∀x. q.fp_state.opts _ = _` $ gs o single o GSYM + \\ rename1 `sa.fp_state.choices ≤ q.fp_state.choices` + \\ ‘sa.fp_state.choices = q.fp_state.choices’ by gs[] + \\ pop_assum $ fs o single) >- ( ntac 2 (TOP_CASE_TAC \\ fs[]) >- (trivial) \\ ntac 2 (TOP_CASE_TAC \\ fs[]) @@ -1497,7 +1539,10 @@ Proof \\ qpat_x_assum ‘∀ outcome. _ ≠ Rerr (Rabort _)’ mp_tac \\ ntac 4 TOP_CASE_TAC \\ gs[shift_fp_opts_def]) \\ TRY (rename1 ‘_ = Force’ - \\ cheat) + \\ Cases_on `op` \\ gvs[] \\ Cases_on `t` \\ gvs[] + \\ gvs [AllCaseEqs()] + \\ imp_res_tac evaluate_io_events_mono_imp \\ gvs[] + \\ drule_all io_events_mono_antisym \\ gvs[]) \\ TRY (imp_res_tac do_app_io_events_mono \\ imp_res_tac io_events_mono_trans \\ CHANGED_TAC (rpt @@ -1694,7 +1739,9 @@ Proof \\ TRY (rename [`Case ([App _ _])`] ORELSE cheat) *) \\ TRY (rename [`Case ([App _ _])`] - \\ Cases_on ‘getOpClass op = Force’ >- cheat + \\ Cases_on ‘getOpClass op = Force’ >- ( + Cases_on `op` \\ gvs[] \\ Cases_on `t` \\ gvs[] + \\ gvs[AllCaseEqs(), dec_clock_def]) \\ Cases_on ‘getOpClass op’ \\ gs[] \\ rpt (MAP_FIRST (dxrule_then (strip_assume_tac o SIMP_RULE bool_ss [])) [hd (RES_CANON pair_case_eq), hd (RES_CANON result_case_eq), hd (RES_CANON bool_case_eq)] diff --git a/translator/ml_optimiseScript.sml b/translator/ml_optimiseScript.sml index 2773ccd6d1..310ab63067 100644 --- a/translator/ml_optimiseScript.sml +++ b/translator/ml_optimiseScript.sml @@ -211,7 +211,18 @@ Proof \\ asm_exists_tac \\ fs [] \\ fs [evaluateTheory.dec_clock_def,state_component_equality]) THEN1 (* App Force *) - cheat + (rename1 `_ = (st1,Rval vs)` + \\ `evaluate (s with clock := ck1) env (REVERSE xs) = + ((st1 with clock := s1.clock) with clock := st1.clock,Rval vs)` + by fs [state_component_equality] + \\ first_x_assum drule \\ simp [] \\ strip_tac + \\ drule evaluate_add_to_clock \\ fs [] + \\ disch_then (qspec_then `st1.clock` assume_tac) + \\ asm_exists_tac \\ fs [] + \\ gvs [AllCaseEqs(), dec_clock_def, PULL_EXISTS] >- metis_tac [] + \\ qpat_x_assum `evaluate _ (sing_env _ _) _ = _` assume_tac + \\ drule evaluate_add_to_clock \\ rw [] + \\ metis_tac []) THEN1 (* App Simple *) (rename1 `_ = (st1,Rval vs)` \\ `evaluate (s with clock := ck1) env (REVERSE xs) = From bf369c684d03a3d0fb282e008d613c469cf020ec Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Tue, 13 May 2025 03:21:38 +0300 Subject: [PATCH 017/112] Fixed force semantics. Data proofs failing --- compiler/backend/bvi_to_dataScript.sml | 1 + compiler/backend/bvl_handleScript.sml | 2 +- compiler/backend/dataLangScript.sml | 1 + compiler/backend/data_liveScript.sml | 2 + compiler/backend/data_spaceScript.sml | 1 + compiler/backend/flat_to_closScript.sml | 5 - .../backend/proofs/bvi_tailrecProofScript.sml | 48 +- .../backend/proofs/bvl_constProofScript.sml | 3 + .../backend/proofs/bvl_handleProofScript.sml | 1 + .../backend/proofs/bvl_inlineProofScript.sml | 88 +++- .../backend/proofs/bvl_to_bviProofScript.sml | 494 +++++++++++++++++- .../backend/proofs/clos_callProofScript.sml | 3 +- .../backend/proofs/clos_fvsProofScript.sml | 22 +- .../backend/proofs/clos_interpProofScript.sml | 8 +- .../backend/proofs/clos_knownProofScript.sml | 27 +- .../backend/proofs/clos_letopProofScript.sml | 22 +- .../backend/proofs/clos_mtiProofScript.sml | 3 +- .../backend/proofs/clos_numberProofScript.sml | 1 + .../backend/proofs/clos_ticksProofScript.sml | 1 + .../backend/proofs/clos_to_bvlProofScript.sml | 460 +++++++++++++--- .../backend/proofs/data_spaceProofScript.sml | 23 +- .../proofs/flat_patternProofScript.sml | 6 +- .../proofs/flat_to_closProofScript.sml | 18 +- .../backend/proofs/source_evalProofScript.sml | 10 +- .../proofs/source_to_flatProofScript.sml | 24 +- compiler/backend/semantics/bviPropsScript.sml | 22 +- compiler/backend/semantics/bviSemScript.sml | 70 ++- compiler/backend/semantics/bvlPropsScript.sml | 80 +-- compiler/backend/semantics/bvlSemScript.sml | 82 ++- compiler/backend/semantics/closSemScript.sml | 30 +- .../backend/semantics/dataPropsScript.sml | 150 +++++- compiler/backend/semantics/dataSemScript.sml | 72 ++- compiler/backend/semantics/flatSemScript.sml | 30 +- semantics/evaluateScript.sml | 38 +- semantics/proofs/evaluatePropsScript.sml | 9 +- 35 files changed, 1559 insertions(+), 298 deletions(-) diff --git a/compiler/backend/bvi_to_dataScript.sml b/compiler/backend/bvi_to_dataScript.sml index 4d229ad054..6bcf1fd60e 100644 --- a/compiler/backend/bvi_to_dataScript.sml +++ b/compiler/backend/bvi_to_dataScript.sml @@ -33,6 +33,7 @@ Theorem op_space_reset_pmatch: | MemOp (CopyByte new_flag) => new_flag | MemOp ConfigGC => T | FFI _ => T + | ThunkOp ForceThunk => T | _ => F Proof rpt strip_tac diff --git a/compiler/backend/bvl_handleScript.sml b/compiler/backend/bvl_handleScript.sml index 86c700f8d4..51f16fe736 100644 --- a/compiler/backend/bvl_handleScript.sml +++ b/compiler/backend/bvl_handleScript.sml @@ -15,7 +15,7 @@ Definition can_raise_def: (can_raise (Let xs x2) = (can_raise x2 ∨ can_raise1 xs)) ∧ (can_raise (Handle x1 x2) = can_raise x2) ∧ (can_raise (Raise x1) = T) ∧ - (can_raise (Op op xs) = can_raise1 xs) ∧ + (can_raise (Op op xs) = (op = ThunkOp ForceThunk ∨ can_raise1 xs)) ∧ (can_raise (Tick x) = can_raise x) ∧ (can_raise (Call t dest xs) = T) ∧ (can_raise1 [] = F) ∧ diff --git a/compiler/backend/dataLangScript.sml b/compiler/backend/dataLangScript.sml index 31d722e164..86c4775029 100644 --- a/compiler/backend/dataLangScript.sml +++ b/compiler/backend/dataLangScript.sml @@ -50,6 +50,7 @@ Definition op_space_reset_def: (op_space_reset (MemOp (CopyByte new_flag)) = new_flag) /\ (op_space_reset (MemOp ConfigGC) = T) /\ (op_space_reset (FFI _) = T) /\ + (op_space_reset (ThunkOp ForceThunk) = T) /\ (op_space_reset _ = F) End diff --git a/compiler/backend/data_liveScript.sml b/compiler/backend/data_liveScript.sml index acca3867a4..b7dd295d88 100644 --- a/compiler/backend/data_liveScript.sml +++ b/compiler/backend/data_liveScript.sml @@ -43,6 +43,7 @@ Definition is_pure_def: (is_pure (MemOp (CopyByte _)) = F) /\ (is_pure (MemOp ConfigGC) = F) /\ (is_pure Install = F) /\ + (is_pure (ThunkOp _) = F) /\ (is_pure _ = T) End @@ -83,6 +84,7 @@ Theorem is_pure_pmatch: | IntOp LessEq => F | Install => F | MemOp ConfigGC => F + | ThunkOp _ => F | _ => T Proof rpt strip_tac diff --git a/compiler/backend/data_spaceScript.sml b/compiler/backend/data_spaceScript.sml index deecf91510..0fa1f4a91b 100644 --- a/compiler/backend/data_spaceScript.sml +++ b/compiler/backend/data_spaceScript.sml @@ -36,6 +36,7 @@ Definition op_space_req_def: (op_space_req (WordOp (FP_uop _)) _ = 3) /\ (op_space_req (WordOp (FP_bop _)) _ = 3) /\ (op_space_req (WordOp (FP_top _)) _ = 3) /\ + (op_space_req (ThunkOp (AllocThunk _)) l = l + 1) /\ (op_space_req _ _ = 0) End diff --git a/compiler/backend/flat_to_closScript.sml b/compiler/backend/flat_to_closScript.sml index 95294f8407..c9c74d8d90 100644 --- a/compiler/backend/flat_to_closScript.sml +++ b/compiler/backend/flat_to_closScript.sml @@ -96,11 +96,6 @@ Definition CopyByteAw8_def: CopyByteAw8 t = ^checkF End -Definition thunk_mode_to_digit_def[simp]: - thunk_mode_to_digit NotEvaluated : num = 0 ∧ - thunk_mode_to_digit Evaluated = 1 -End - Definition compile_op_def: compile_op t op xs = dtcase op of diff --git a/compiler/backend/proofs/bvi_tailrecProofScript.sml b/compiler/backend/proofs/bvi_tailrecProofScript.sml index fcba1547a8..150e73fc4c 100644 --- a/compiler/backend/proofs/bvi_tailrecProofScript.sml +++ b/compiler/backend/proofs/bvi_tailrecProofScript.sml @@ -570,7 +570,15 @@ Proof \\ rfs [EL_APPEND1, EL_APPEND2, EL_LENGTH_APPEND]) \\ CASE_TAC \\ fs [] >- - (rw [case_eq_thms, case_elim_thms, IS_SOME_EXISTS, PULL_EXISTS, bool_case_eq, + (Cases_on `op = ThunkOp ForceThunk` + >- ( + gvs [AllCaseEqs()] + >- gvs [ty_rel_def] + \\ qspecl_then + [`[AppUnit]`, `[v]`, `dec_clock 1 s'`] assume_tac evaluate_LENGTH + \\ gvs [] + \\ Cases_on `vs` \\ gvs [ty_rel_def]) + \\ rw [case_eq_thms, case_elim_thms, IS_SOME_EXISTS, PULL_EXISTS, bool_case_eq, pair_case_eq, from_op_def, arg_ty_def, op_ty_def] \\ fs [pair_case_eq, case_elim_thms, case_eq_thms] \\ rw [] \\ fs [] \\ fs [op_type_def, arg_ty_def, ty_rel_def, get_bin_args_def, case_elim_thms, @@ -595,6 +603,7 @@ Proof \\ rpt (PURE_TOP_CASE_TAC \\ fs []) \\ rveq \\ fs [evaluate_def, bool_case_eq, pair_case_eq, case_eq_thms, case_elim_thms] \\ rveq \\ fs [] \\ rveq \\ rfs [] + \\ imp_res_tac evaluate_SING_IMP \\ gvs [] \\ metis_tac [] QED @@ -1260,6 +1269,12 @@ Proof Cases_on `op` \\ fs [op_type_def] QED +Triviality to_op_not_ForceThunk[simp]: + ∀op. to_op op ≠ ThunkOp ForceThunk +Proof + strip_tac \\ gvs [oneline to_op_def, AllCaseEqs()] +QED + Theorem evaluate_rewrite_tail: ∀xs ^s env1 r t opt s' acc env2 loc ts ty. evaluate (xs, env1, s) = (r, t) ∧ @@ -1625,7 +1640,36 @@ Proof \\ simp [LEFT_EXISTS_AND_THM, CONJ_ASSOC] \\ conj_tac >- - (first_x_assum (qspecl_then [`xs`, `s`] mp_tac) + (Cases_on `op = ThunkOp ForceThunk` + >- ( + gvs [] + \\ last_assum $ qspecl_then [`xs`, `s`] mp_tac \\ gvs[] + \\ impl_tac + >- simp [bviTheory.exp_size_def] + \\ `env_rel ty F acc env1 env2` by fs [env_rel_def] \\ gvs [] + \\ rpt (disch_then drule) \\ rw [] + \\ gvs [AllCaseEqs(), PULL_EXISTS] + \\ `r'.refs = t'.refs` by gvs [state_rel_def] + \\ `r'.clock = t'.clock` by gvs [state_rel_def] + \\ gvs [] + \\ ( + gvs [PULL_EXISTS] + \\ last_x_assum $ qspecl_then [`[AppUnit]`, `dec_clock 1 r'`] mp_tac + \\ impl_tac + >- (imp_res_tac evaluate_clock \\ gvs [dec_clock_def]) + \\ disch_then drule \\ gvs [] + \\ `env_rel ty F acc [v] [v]` by gvs [env_rel_def] + \\ disch_then drule \\ gvs [] + \\ `state_rel (dec_clock 1 r') (dec_clock 1 t')` by + gvs [state_rel_def, dec_clock_def] + \\ disch_then drule \\ gvs [] + \\ `ty_rel [v] [Any]` by gvs [ty_rel_def] + \\ disch_then drule \\ gvs [] \\ rw [] + \\ goal_assum drule \\ gvs [] + \\ `s''.refs = t''.refs` by gvs [state_rel_def] \\ gvs [] + \\ gvs [state_rel_def])) + \\ gvs [] + \\ first_x_assum (qspecl_then [`xs`, `s`] mp_tac) \\ simp [bviTheory.exp_size_def] \\ `env_rel ty F acc env1 env2` by fs [env_rel_def] \\ rpt (disch_then drule) \\ fs [] diff --git a/compiler/backend/proofs/bvl_constProofScript.sml b/compiler/backend/proofs/bvl_constProofScript.sml index 1107455874..647e3e6732 100644 --- a/compiler/backend/proofs/bvl_constProofScript.sml +++ b/compiler/backend/proofs/bvl_constProofScript.sml @@ -187,6 +187,7 @@ Proof rw [REVERSE_DEF] \\ imp_res_tac evaluate_SING \\ fs [] \\ + gvs [oneline dest_thunk_def, AllCaseEqs()] \\ intLib.COOPER_TAC) \\ fs [] \\ every_case_tac \\ fs [] @@ -294,6 +295,8 @@ Proof \\ res_tac \\ rw [] \\ Cases_on `e` \\ fs [] \\ rw [] \\ fs [] \\ first_x_assum match_mp_tac \\ fs [env_rel_def]) + \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs [] + >- (gvs [AllCaseEqs()] \\ irule SmartOp_thm \\ rw [evaluate_def]) \\ TRY (match_mp_tac SmartOp_thm) \\ fs [evaluate_def] \\ every_case_tac \\ fs [] \\ rw [] \\ fs [] \\ res_tac \\ fs [] \\ rw [] \\ fs [] \\ rw [] \\ fs [] diff --git a/compiler/backend/proofs/bvl_handleProofScript.sml b/compiler/backend/proofs/bvl_handleProofScript.sml index 705e803b45..025a74f7e0 100644 --- a/compiler/backend/proofs/bvl_handleProofScript.sml +++ b/compiler/backend/proofs/bvl_handleProofScript.sml @@ -440,6 +440,7 @@ Theorem compile_correct = Q.prove(` \\ drule (GEN_ALL OptionalLetLet_limit) \\ imp_res_tac OptionalLetLet_nr \\ fs [env_rel_mk_Union] \\ strip_tac + \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs [] >- cheat \\ Cases_on `evaluate (xs,env,s)` \\ Cases_on `q` \\ fs [] \\ rw [] \\ res_tac \\ fs [evaluate_def] \\ every_case_tac \\ fs [] \\ rveq \\ fs [] diff --git a/compiler/backend/proofs/bvl_inlineProofScript.sml b/compiler/backend/proofs/bvl_inlineProofScript.sml index fb65318934..2fa54e27f1 100644 --- a/compiler/backend/proofs/bvl_inlineProofScript.sml +++ b/compiler/backend/proofs/bvl_inlineProofScript.sml @@ -213,6 +213,37 @@ Proof \\ drule evaluate_add_clock \\ fs [inc_clock_def]) THEN1 (* Op *) (fs [remove_ticks_def,evaluate_def] + \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs [] + >- ( + Cases_on `evaluate (remove_ticks xs,env,s)` \\ gvs [] + \\ reverse $ Cases_on `q` \\ gvs [] + >- ( + first_x_assum drule \\ gvs [] + \\ disch_then drule \\ strip_tac + \\ qexists `ck` \\ gvs []) + \\ first_x_assum drule \\ gvs [] + \\ disch_then drule \\ strip_tac + \\ `t'.refs = r.refs` by gvs [state_rel_def] + \\ `t'.clock = r.clock` by gvs [state_rel_def] + \\ gvs [AllCaseEqs(), PULL_EXISTS] + \\ TRY (qexists `ck` \\ gvs [] \\ NO_TAC) + \\ ( + qrefine `ck' + ck` + \\ `∀ck'. evaluate (xs,env,t with clock := ck' + ck + t.clock) = + (Rval a,t' with clock := ck' + t'.clock)` by ( + imp_res_tac evaluate_add_clock \\ gvs [inc_clock_def]) + \\ gvs [PULL_EXISTS] + \\ `evaluate (remove_ticks [AppUnit],[v],dec_clock 1 r) = + evaluate ([AppUnit],[v],dec_clock 1 r)` + by gvs [AppUnit_def, mk_unit_def, remove_ticks_def] + \\ gvs [] + \\ `(dec_clock 1 r).clock < s.clock` by ( + imp_res_tac evaluate_clock \\ gvs [dec_clock_def]) + \\ `state_rel (dec_clock 1 t') (dec_clock 1 r)` by ( + gvs [state_rel_def, dec_clock_def]) + \\ last_x_assum drule_all \\ rw [dec_clock_def] + \\ goal_assum drule \\ gvs [] + \\ gvs [state_rel_def])) \\ FULL_CASE_TAC \\ fs [] \\ first_x_assum drule \\ fs [] \\ disch_then drule \\ strip_tac @@ -907,6 +938,16 @@ Proof \\ imp_res_tac do_app_const \\ fs [] QED +Theorem exp_rel_refl: + !cs xs. exp_rel cs xs xs +Proof + ho_match_mp_tac tick_inline_ind \\ rw [] + \\ once_rewrite_tac [exp_rel_cases] \\ fs [] + \\ Cases_on `dest` \\ fs [] + \\ Cases_on `lookup x cs` \\ fs [] + \\ Cases_on `x'` \\ fs [] +QED + Theorem evaluate_inline: !es env s1 res t1 s2 es2. in_state_rel limit s1 t1 /\ exp_rel s1.code es es2 /\ @@ -965,7 +1006,20 @@ Proof \\ drule subspt_exp_rel \\ disch_then drule \\ rw [] \\ pop_assum drule \\ rw [] \\ fs []) THEN1 - (fs [case_eq_thms] \\ rveq \\ fs [] + (Cases_on `op = ThunkOp ForceThunk` \\ gvs [] + >- ( + gvs [evaluate_def] + \\ gvs [AllCaseEqs(), PULL_EXISTS] + \\ ( + first_x_assum drule_all \\ rw [] \\ gvs [PULL_EXISTS] + \\ `s'.refs = t2.refs` by gvs [in_state_rel_def] \\ gvs [PULL_EXISTS] + \\ `s'.clock = t2.clock` by gvs [in_state_rel_def] \\ gvs [] + \\ `in_state_rel limit (dec_clock 1 s') (dec_clock 1 t2)` + by gvs [in_state_rel_def, dec_clock_def] + \\ last_x_assum drule + \\ disch_then $ qspec_then `[AppUnit]` assume_tac + \\ gvs [exp_rel_refl, in_state_rel_def])) + \\ fs [case_eq_thms] \\ rveq \\ fs [] \\ first_x_assum drule \\ disch_then drule \\ strip_tac \\ fs [evaluate_def] @@ -1024,16 +1078,6 @@ Proof \\ drule evaluate_expand_env \\ fs [] QED -Theorem exp_rel_refl: - !cs xs. exp_rel cs xs xs -Proof - ho_match_mp_tac tick_inline_ind \\ rw [] - \\ once_rewrite_tac [exp_rel_cases] \\ fs [] - \\ Cases_on `dest` \\ fs [] - \\ Cases_on `lookup x cs` \\ fs [] - \\ Cases_on `x'` \\ fs [] -QED - Definition in_co_def: in_co limit co = (λn. (let @@ -1526,6 +1570,14 @@ Proof (first_x_assum drule \\ rw [] \\ fs [] \\ TOP_CASE_TAC \\ fs [] \\ fs [evaluate_def] + \\ Cases_on `x = ThunkOp ForceThunk` \\ gvs [] >- ( + Cases_on `HD (let_op [x2])` \\ gvs [dest_op_def] + \\ drule (GEN_ALL var_list_IMP_evaluate) \\ fs [LENGTH_let_op] + \\ imp_res_tac evaluate_IMP_LENGTH + \\ disch_then drule \\ rw [] + \\ qsuff_tac `let_op [x2] = [Op (ThunkOp ForceThunk) l]` + >- (rw [] \\ gvs [evaluate_def]) + \\ once_rewrite_tac [GSYM HD_let_op] \\ gvs []) \\ Cases_on `HD (let_op [x2])` \\ fs [dest_op_def] \\ rveq \\ drule (GEN_ALL var_list_IMP_evaluate) \\ fs [LENGTH_let_op] \\ imp_res_tac evaluate_IMP_LENGTH @@ -1543,7 +1595,19 @@ Proof (fs [case_eq_thms] \\ rveq \\ fs [] \\ res_tac \\ fs [] \\ res_tac \\ fs []) THEN1 - (fs [case_eq_thms] \\ rveq \\ fs [] + (Cases_on `op = ThunkOp ForceThunk` \\ gvs [] + >- ( + gvs [AllCaseEqs(), PULL_EXISTS] + \\ ( + first_x_assum drule \\ rw [] \\ gvs [PULL_EXISTS] + \\ `s'.refs = t2.refs` by gvs [let_state_rel_def] \\ gvs [PULL_EXISTS] + \\ `s'.clock = t2.clock` by gvs [let_state_rel_def] \\ gvs [] + \\ `let_state_rel q4 l4 (dec_clock 1 s') (dec_clock 1 t2)` + by gvs [let_state_rel_def, dec_clock_def] + \\ last_x_assum drule \\ rw [AppUnit_def, let_op_def, mk_unit_def] + \\ gvs [] + \\ gvs [let_state_rel_def])) + \\ fs [case_eq_thms] \\ rveq \\ fs [] \\ res_tac \\ fs [] \\ res_tac \\ fs [] \\ rveq \\ fs [] \\ drule (do_app_lemma |> Q.GEN `a` |> Q.SPEC `REVERSE vs`) diff --git a/compiler/backend/proofs/bvl_to_bviProofScript.sml b/compiler/backend/proofs/bvl_to_bviProofScript.sml index 63736ffbfe..a7b92b6ddb 100644 --- a/compiler/backend/proofs/bvl_to_bviProofScript.sml +++ b/compiler/backend/proofs/bvl_to_bviProofScript.sml @@ -102,6 +102,8 @@ Definition state_rel_def: | NONE => T | SOME (ValueArray vs) => (FLOOKUP t.refs (b k) = SOME (ValueArray (MAP (adjust_bv b) vs))) + | SOME (Thunk m v) => + (FLOOKUP t.refs (b k) = SOME (Thunk m (adjust_bv b v))) | SOME res => (FLOOKUP t.refs (b k) = SOME res)) /\ (s.ffi = t.ffi) /\ (∀p. t.global = SOME p ⇒ @@ -142,6 +144,24 @@ Proof >> rfs[] QED +Theorem state_rel_FLOOKUP_valueArray: + state_rel b s t ∧ + FLOOKUP s.refs ptr = SOME (ValueArray vs) ⇒ + FLOOKUP t.refs (b ptr) = SOME (ValueArray (MAP (adjust_bv b) vs)) +Proof + rw [state_rel_def] + \\ rpt (first_x_assum $ qspec_then `ptr` assume_tac \\ gvs []) +QED + +Theorem state_rel_FLOOKUP_Thunk: + state_rel b s t ∧ + FLOOKUP s.refs ptr = SOME (Thunk m v) ⇒ + FLOOKUP t.refs (b ptr) = SOME (Thunk m (adjust_bv b v)) +Proof + rw [state_rel_def] + \\ rpt (first_x_assum $ qspec_then `ptr` assume_tac \\ gvs []) +QED + Definition bv_ok_def: (bv_ok (refs: num |-> v ref) (RefPtr l r) <=> r IN FDOM refs) /\ (bv_ok refs (Block tag vs) <=> EVERY (bv_ok refs) vs) /\ @@ -190,6 +210,7 @@ Definition state_ok_def: EVERY (\x. case x of NONE => T | SOME v => bv_ok s.refs v) s.globals /\ !k. case FLOOKUP s.refs k of | SOME (ValueArray vs) => EVERY (bv_ok s.refs) vs + | SOME (Thunk _ v) => bv_ok s.refs v | _ => T End @@ -504,6 +525,50 @@ Proof rename1 `ToListByte` \\ qspec_tac (`l`,`l`) \\ Induct \\ fs [bv_ok_def,list_to_v_def] ) + >- ( + rename1 `AllocThunk` \\ gvs [] \\ rw [] + >- ( + gvs [state_ok_def, bvlSemTheory.state_component_equality] \\ rw [] + >- ( + gvs [EVERY_EL] \\ rw [] + \\ first_x_assum drule \\ rw [] + \\ CASE_TAC \\ gvs [] + \\ irule bv_ok_SUBSET_IMP \\ gvs [] + \\ goal_assum $ drule_at Any \\ gvs [LEAST_NOTIN_FDOM]) + >- ( + gvs [FLOOKUP_DEF, FAPPLY_FUPDATE_THM] \\ rw [] + >- ( + irule bv_ok_SUBSET_IMP \\ gvs [] + \\ goal_assum $ drule_at Any \\ gvs [LEAST_NOTIN_FDOM]) + \\ first_x_assum $ qspec_then `k` assume_tac \\ gvs [] + \\ CASE_TAC \\ gvs [EVERY_EL] \\ rw [] + \\ rpt (first_x_assum drule \\ rw []) + \\ irule bv_ok_SUBSET_IMP \\ gvs [] + \\ goal_assum $ drule_at Any \\ gvs [LEAST_NOTIN_FDOM])) + >- ( + gvs [state_ok_def, bvlSemTheory.state_component_equality] \\ rw [] + \\ simp [bv_ok_def])) + >- ( + rename1 `UpdateThunk` \\ gvs [] + \\ gvs [bv_ok_def, state_ok_def, bvlSemTheory.state_component_equality] + \\ rw [] + >- ( + gvs [EVERY_EL] \\ rw [] + \\ first_x_assum drule \\ rw [] + \\ CASE_TAC \\ gvs [] + \\ irule bv_ok_SUBSET_IMP \\ gvs [] + \\ goal_assum $ drule_at Any \\ gvs [ABSORPTION]) + >- ( + simp [FLOOKUP_UPDATE] \\ rw [] + >- ( + irule bv_ok_SUBSET_IMP \\ gvs [] + \\ goal_assum $ drule_at Any \\ gvs [ABSORPTION]) + \\ first_x_assum $ qspec_then `k` assume_tac \\ gvs [] + \\ rpt (CASE_TAC \\ gvs []) + \\ gvs [EVERY_EL] \\ rw [] + \\ rpt (first_x_assum drule \\ rw []) + \\ irule bv_ok_SUBSET_IMP \\ gvs [] + \\ goal_assum $ drule_at Any \\ gvs [ABSORPTION])) QED Theorem do_app_ok: @@ -547,6 +612,133 @@ Theorem evaluate_ok: EVERY (bv_ok t.refs) env Proof recInduct bvlSemTheory.evaluate_ind \\ rpt strip_tac + >>~ [`ForceThunk`] + >- ( + Cases_on `op = ThunkOp ForceThunk` \\ gvs [] + >- ( + fs [bvlSemTheory.evaluate_def] \\ rw [] \\ fs [] + \\ fs [case_eq_thms] \\ rveq \\ fs [] + \\ `state_ok (dec_clock 1 s')` by + gvs [state_ok_def, bvlSemTheory.dec_clock_def] + \\ gvs [AllCaseEqs()] + \\ `bv_ok s'.refs v` by ( + gvs [oneline bvlSemTheory.dest_thunk_def, AllCaseEqs(), state_ok_def] + \\ rpt (first_x_assum $ qspec_then `ptr` assume_tac \\ gvs [])) + \\ gvs [oneline bvlSemTheory.update_thunk_def, AllCaseEqs(), + bvlSemTheory.store_thunk_def] + \\ qpat_x_assum `state_ok s''` mp_tac + \\ rw [state_ok_def] + >- ( + gvs [EVERY_EL] \\ rw [] + \\ first_x_assum drule \\ rw [] + \\ CASE_TAC \\ gvs [] + \\ irule bv_ok_SUBSET_IMP \\ gvs [] + \\ goal_assum $ drule_at Any \\ gvs [FLOOKUP_DEF, ABSORPTION]) + >- ( + gvs [FLOOKUP_UPDATE] \\ rw [] + >- ( + irule bv_ok_SUBSET_IMP \\ gvs [] + \\ goal_assum $ drule_at Any \\ gvs [FLOOKUP_DEF, ABSORPTION]) + \\ first_x_assum $ qspec_then `k` assume_tac \\ gvs [] + \\ rpt (CASE_TAC \\ gvs []) + >- ( + gvs [EVERY_EL] \\ rw [] + \\ first_x_assum drule \\ rw [] + \\ irule bv_ok_SUBSET_IMP \\ gvs [] + \\ goal_assum $ drule_at Any \\ gvs [FLOOKUP_DEF, ABSORPTION]) + >- ( + irule bv_ok_SUBSET_IMP \\ gvs [] + \\ goal_assum $ drule_at Any \\ gvs [FLOOKUP_DEF, ABSORPTION]))) + \\ fs[bvlSemTheory.evaluate_def] \\ rw [] \\ fs [] + \\ fs [case_eq_thms] \\ rveq \\ fs [] + \\ imp_res_tac evaluate_IMP_bv_ok \\ fs [] + \\ ( + do_app_ok + |> REWRITE_RULE [CONJ_ASSOC] + |> ONCE_REWRITE_RULE [CONJ_COMM] |> GEN_ALL |> drule) + \\ fs [EVERY_REVERSE]) + >- ( + Cases_on `op = ThunkOp ForceThunk` \\ gvs [] + >- ( + fs [bvlSemTheory.evaluate_def] \\ rw [] \\ fs [] + \\ fs [case_eq_thms] \\ rveq \\ fs [] + \\ gvs [AllCaseEqs()] + >- ( + gvs [oneline bvlSemTheory.dest_thunk_def, AllCaseEqs()] + \\ qpat_x_assum `state_ok s'` mp_tac \\ rw [state_ok_def] + \\ pop_assum $ qspec_then `ptr` assume_tac \\ gvs []) + >- ( + `state_ok (dec_clock 1 s')` by + gvs [state_ok_def, bvlSemTheory.dec_clock_def] + \\ gvs [] + \\ `bv_ok s'.refs v` by ( + gvs [oneline bvlSemTheory.dest_thunk_def, AllCaseEqs(), state_ok_def] + \\ rpt (first_x_assum $ qspec_then `ptr` assume_tac \\ gvs [])) + \\ gvs [oneline bvlSemTheory.update_thunk_def, AllCaseEqs(), + bvlSemTheory.store_thunk_def] + \\ irule bv_ok_SUBSET_IMP \\ gvs [] + \\ goal_assum $ drule_at Any \\ gvs [FLOOKUP_DEF, ABSORPTION]) + >- ( + CASE_TAC \\ gvs [] + \\ pop_assum mp_tac \\ impl_tac + >- ( + rw [] + >- gvs [state_ok_def, bvlSemTheory.dec_clock_def] + >- ( + gvs [oneline bvlSemTheory.dest_thunk_def, AllCaseEqs(), + state_ok_def] + \\ rpt (first_x_assum $ qspec_then `ptr` assume_tac \\ gvs []))) + \\ gvs [])) + \\ fs [bvlSemTheory.evaluate_def] \\ rw [] \\ fs [] + \\ fs [case_eq_thms] \\ rveq \\ fs [] + >- ( + imp_res_tac evaluate_IMP_bv_ok \\ fs [] + \\ ( + do_app_ok + |> REWRITE_RULE [CONJ_ASSOC] + |> ONCE_REWRITE_RULE [CONJ_COMM] |> GEN_ALL |> drule) + \\ fs [EVERY_REVERSE]) + >- ( + imp_res_tac evaluate_IMP_bv_ok \\ fs [] + \\ every_case_tac \\ fs [] + \\ imp_res_tac bvlPropsTheory.do_app_err \\ fs[evaluate_ok_lemma])) + >- ( + Cases_on `op = ThunkOp ForceThunk` \\ gvs [] + >- ( + fs [bvlSemTheory.evaluate_def] \\ rw [] \\ fs [] + \\ fs [case_eq_thms] \\ rveq \\ fs [] + \\ gvs [AllCaseEqs()] + >- ( + imp_res_tac evaluate_refs_SUBSET + \\ gvs [EVERY_EL] \\ rw [] + \\ irule bv_ok_SUBSET_IMP + \\ goal_assum drule \\ gvs []) + >- ( + gvs [EVERY_EL] \\ rw [] + \\ rpt (first_x_assum drule \\ rw []) + \\ gvs [oneline bvlSemTheory.update_thunk_def, AllCaseEqs(), + bvlSemTheory.store_thunk_def] + \\ `bv_ok s''.refs (EL n env)` by ( + imp_res_tac evaluate_refs_SUBSET + \\ gvs [dec_clock_def] + \\ irule bv_ok_SUBSET_IMP + \\ goal_assum drule \\ gvs []) + \\ gvs [] + \\ irule bv_ok_SUBSET_IMP \\ rw [] + \\ goal_assum $ drule_at Any \\ gvs [FLOOKUP_DEF, ABSORPTION]) + >- ( + imp_res_tac evaluate_refs_SUBSET + \\ gvs [EVERY_EL] \\ rw [] + \\ irule bv_ok_SUBSET_IMP + \\ goal_assum drule \\ gvs [])) + \\ fs [bvlSemTheory.evaluate_def] \\ rw [] \\ fs [] + \\ fs [case_eq_thms] \\ rveq \\ fs [] + \\ imp_res_tac evaluate_IMP_bv_ok \\ fs [] + \\ ( + do_app_ok + |> REWRITE_RULE [CONJ_ASSOC] + |> ONCE_REWRITE_RULE [CONJ_COMM] |> GEN_ALL |> drule) + \\ fs [EVERY_REVERSE]) \\ fs[bvlSemTheory.evaluate_def] \\ rw [] \\ fs [] \\ fs [case_eq_thms] \\ rveq \\ fs [] \\ imp_res_tac evaluate_SING \\ fs[] \\ rveq \\ fs [] @@ -1272,6 +1464,7 @@ Theorem do_app_adjust[local]: (∀flag. op ≠ MemOp (RefByte flag)) ∧ (op ≠ MemOp RefArray) ∧ (∀n. op ≠ GlobOp (Global n)) ∧ (∀n. op ≠ GlobOp (SetGlobal n)) ∧ (op ≠ GlobOp AllocGlobal) ∧ op ≠ Install /\ + (∀t. op ≠ ThunkOp t) ∧ (∀n. op ≠ BlockOp (FromList n)) ∧ (op ≠ MemOp FromListByte) ∧ (op ≠ MemOp ToListByte) ∧ (∀c. op ≠ BlockOp (Build c)) ∧ (∀b. op ≠ MemOp (CopyByte b)) ∧ (op ≠ MemOp ConcatByteVec) ∧ (∀n. op ≠ Label n) ∧ @@ -1546,7 +1739,14 @@ Theorem eval_ind_alt: P ([x2],v::env,s)) ∧ (∀xs env. exp1_size xs <= exp_size x1 ⇒ P (xs,env,s1)) ⇒ P ([Handle x1 x2],env,s1)) ∧ - (∀op xs env s. P (xs,env,s) ⇒ P ([Op op xs],env,s)) ∧ + (∀op xs env s. + (∀v6 s' vs v1 v. + evaluate (xs,env,s) = (v6,s') ∧ v6 = Rval vs ∧ + op = ThunkOp ForceThunk ∧ + dest_thunk vs s'.refs = IsThunk v1 v ∧ v1 = NotEvaluated ∧ + s'.clock ≠ 0 ⇒ + P ([AppUnit],[v],dec_clock 1 s')) ∧ P (xs,env,s) ⇒ + P ([Op op xs],env,s)) ∧ (∀x env s. (s.clock ≠ 0 ⇒ P ([x],env,dec_clock 1 s)) ⇒ P ([Tick x],env,s)) ∧ @@ -1652,6 +1852,85 @@ Proof \\ metis_tac[INJ_DEF] QED +Theorem state_rel_add_thunk: + state_rel b s (t:('c,'ffi) bviSem$state) ∧ + state_ok s ∧ + pp ∉ FDOM s.refs ∧ + qq ∉ FDOM t.refs ⇒ + state_rel ((pp =+ qq) b) + (s with refs := s.refs |+ (pp,Thunk m v)) + (t with refs := t.refs |+ (qq,Thunk m (adjust_bv ((pp =+ qq) b) v))) +Proof + strip_tac + \\ fs [state_rel_def, FLOOKUP_UPDATE] + \\ conj_tac >- (match_mp_tac INJ_EXTEND \\ fs []) + \\ conj_tac >- ( + fs [APPLY_UPDATE_THM] + \\ gen_tac + \\ IF_CASES_TAC \\ fs[] + \\ qpat_x_assum `∀k. option_CASE (FLOOKUP s.refs k) _ _` + $ qspec_then `k` mp_tac + \\ TOP_CASE_TAC \\ simp [] + \\ `qq ≠ b k` + by (pop_assum mp_tac \\ rw [FLOOKUP_DEF] \\ metis_tac [INJ_DEF]) + \\ simp[] + \\ TOP_CASE_TAC \\ rw [MAP_EQ_f] + \\ match_mp_tac (bv_ok_IMP_adjust_bv_eq |> GEN_ALL) + \\ qexists_tac `s.refs` + \\ fs [state_ok_def] + \\ first_x_assum$ qspec_then `k` mp_tac + \\ simp [EVERY_MEM] + \\ rw [APPLY_UPDATE_THM] + \\ metis_tac []) + \\ simp [APPLY_UPDATE_THM] + \\ gen_tac \\ strip_tac + \\ `qq ≠ p` by ( + fs [] + \\ `p ∈ FDOM t.refs` by fs [FLOOKUP_DEF] + \\ metis_tac []) + \\ fs [] \\ conj_tac >- rw [] + \\ simp [APPLY_UPDATE_THM] + \\ qexists `z` \\ simp [MAP_EQ_f] + \\ Cases \\ rw [miscTheory.the_def] + \\ match_mp_tac (GEN_ALL bv_ok_IMP_adjust_bv_eq) + \\ qexists `s.refs` + \\ simp [APPLY_UPDATE_THM] + \\ fs [state_ok_def, EVERY_MEM] + \\ res_tac \\ fs [] + \\ rw [] + \\ metis_tac [INJ_DEF] +QED + +Theorem state_rel_update_thunk: + state_rel b s (t:('c,'ffi) bviSem$state) ∧ + state_ok s ∧ + ptr ∈ FDOM s.refs ⇒ + state_rel b + (s with refs := s.refs |+ (ptr,Thunk m v)) + (t with refs := t.refs |+ (b ptr,Thunk m (adjust_bv b v))) +Proof + rw [] + \\ gvs [state_rel_def] \\ rw [] \\ gvs [] + >- ( + gvs [INJ_DEF] + \\ rw [] + \\ ntac 2 (last_x_assum drule \\ strip_tac) \\ gvs []) + >- ( + gvs [FLOOKUP_UPDATE] \\ rw [] + \\ last_x_assum $ qspec_then `k` assume_tac \\ gvs [] + \\ ntac 2 (CASE_TAC \\ gvs []) + \\ gvs [INJ_DEF, FLOOKUP_DEF]) + >- metis_tac [] + >- ( + gvs [FLOOKUP_UPDATE] \\ rw [] + >- ( + gvs [INJ_DEF] + \\ last_x_assum drule \\ strip_tac + \\ qpat_x_assum `∀x. b ptr ≠ b _ ∨ _` + $ qspec_then `ptr` assume_tac \\ gvs []) + >- metis_tac []) +QED + val iEval_bVarBound_extra = prove( ``∀n xs n vs s env d. bVarBound (LENGTH vs) xs ∧ handle_ok xs /\ d = FST (compile_exps n xs) ⇒ @@ -2373,6 +2652,11 @@ Proof (fs[compile_op_def] \\ qexists_tac`c` \\ simp[] \\ rw [] \\ fs [evaluate_def]) + \\ Cases_on `op = ThunkOp ForceThunk` + >- ( + gvs [compile_op_def] + \\ qexists `c` \\ gvs [] + \\ gvs [evaluate_def]) \\ Cases_on`op = MemOp (CopyByte T)` >- (note_tac "Op: CopyByte" \\ fs[compile_op_def] @@ -2385,6 +2669,143 @@ Proof \\ imp_res_tac compile_exps_LENGTH \\ fs [NULL_EQ,LENGTH_NIL] \\ Cases_on `xs` \\ fs [bviSemTheory.evaluate_def]) + \\ Cases_on `op = ThunkOp ForceThunk` + >- ( + gvs [] \\ rw [GSYM PULL_FORALL] + \\ gvs [compile_op_def, evaluate_def] + \\ qrefinel [`_`, `_`, `c + c'`] \\ gvs [inc_clock_def] + \\ `∀c'. evaluate (c1,MAP (adjust_bv b2) env, + t1 with clock := c + t1.clock + c') = + (Rval (MAP (adjust_bv b2) a), + t2 with clock := t2.clock + c')` by ( + rw [] \\ drule evaluate_add_clock \\ rw [inc_clock_def]) + \\ gvs [AllCaseEqs(), PULL_EXISTS] + \\ gvs [oneline bvlSemTheory.dest_thunk_def, dest_thunk_def, AllCaseEqs(), + adjust_bv_def, PULL_EXISTS] + \\ drule_all state_rel_FLOOKUP_Thunk \\ gvs [PULL_EXISTS] \\ strip_tac + >- ( + qrefinel [`0`, `_`, `b2`] \\ gvs [dest_thunk_def] + \\ `t2 with clock := t2.clock = t2` by gvs [state_component_equality] + \\ gvs []) + >- ( + qrefinel [`0`, `t2`, `b2`] \\ gvs [dest_thunk_def] + \\ gvs [state_component_equality, state_rel_def]) + >- ( + rename1 `state_rel b2 s2 t2` + \\ `s2.clock = t2.clock` by gvs [state_rel_def] \\ gvs [] + \\ `state_rel b2 (dec_clock 1 s2) (dec_clock 1 t2)` by + gvs [state_rel_def, bvlSemTheory.dec_clock_def, dec_clock_def] \\ gvs [] + \\ last_x_assum $ drule_at (Pat `state_rel _ _ _`) + \\ simp [bvlSemTheory.AppUnit_def, compile_exps_def, compile_op_def, + compile_int_def, bvlSemTheory.mk_unit_def] + \\ impl_tac + >- ( + rw [handle_ok_def, aux_code_installed_def] + >- ( + qpat_x_assum `evaluate _ = (_,s2)` assume_tac + \\ drule evaluate_ok \\ rw [] + \\ gvs [state_ok_def, bvlSemTheory.dec_clock_def]) + >- ( + `state_ok s2` by ( + qpat_x_assum `evaluate _ = (_,s2)` assume_tac + \\ drule evaluate_ok \\ rw []) \\ gvs [] + \\ pop_assum mp_tac + \\ rw [state_ok_def] + \\ pop_assum $ qspec_then `ptr` assume_tac \\ gvs []) + >- ( + irule evaluate_global_mono + \\ goal_assum $ drule_at Any \\ gvs [])) + \\ rw [] + \\ gvs [GSYM PULL_FORALL, dec_clock_def] + \\ gvs [GSYM AppUnit_def] + \\ qrefinel [`c'`, `_`, `b2'`] \\ gvs [] + \\ `MAP (adjust_bv b2) env = MAP (adjust_bv b2') env` by ( + full_simp_tac(srw_ss())[MAP_EQ_f] \\ REPEAT STRIP_TAC + \\ MATCH_MP_TAC (GEN_ALL bv_ok_IMP_adjust_bv_eq) + \\ qexists_tac `s2.refs` + \\ full_simp_tac(srw_ss())[EVERY_MEM] \\ RES_TAC + \\ IMP_RES_TAC evaluate_refs_SUBSET + \\ REPEAT STRIP_TAC THEN1 METIS_TAC [bv_ok_SUBSET_IMP]) + \\ gvs [dest_thunk_def, PULL_EXISTS] + \\ `∀a. a ∈ FDOM s.refs ⇒ b2 a = b2' a` by ( + rw [] + \\ first_x_assum irule \\ gvs [] + \\ imp_res_tac evaluate_refs_SUBSET \\ metis_tac [SUBSET_THM]) + \\ gvs [] + \\ imp_res_tac evaluate_SING \\ gvs [] + \\ `state_ok s''` by ( + qpat_x_assum `evaluate _ = (_,s2)` assume_tac + \\ drule evaluate_ok \\ impl_tac + >- gvs [] + \\ rw [] + \\ qpat_x_assum `evaluate _ = (_,s'')` assume_tac + \\ drule evaluate_ok \\ impl_tac + >- ( + rw [] + >- gvs [evaluate_ok_lemma] + >- ( + qpat_x_assum `state_ok s2` mp_tac + \\ rw [state_ok_def] + \\ pop_assum $ qspec_then `ptr` assume_tac \\ gvs [])) + \\ gvs []) + \\ gvs [bvlSemTheory.update_thunk_def, update_thunk_def] + \\ gvs [AllCaseEqs()] + \\ gvs [oneline bvlSemTheory.dest_thunk_def, oneline dest_thunk_def, + AllCaseEqs(), adjust_bv_def, PULL_EXISTS] + \\ ( + `ptr ∈ FDOM s2.refs` by gvs [FLOOKUP_DEF] + \\ first_x_assum drule \\ strip_tac \\ gvs [] + \\ gvs [bvlSemTheory.store_thunk_def, store_thunk_def, AllCaseEqs(), + PULL_EXISTS, SF ETA_ss] + \\ drule_all state_rel_FLOOKUP_Thunk \\ strip_tac \\ gvs [] + \\ TRY (drule_all state_rel_FLOOKUP_valueArray \\ rw []) + \\ TRY (drule_all state_rel_FLOOKUP_byteArray \\ rw []) + \\ `ptr ∈ FDOM s''.refs` by gvs [FLOOKUP_DEF] + \\ drule_all state_rel_update_thunk \\ rw [] + \\ qmatch_goalsub_abbrev_tac + `state_rel _ (_ with refs := _ |+ (_,Thunk mo va)) _` + \\ first_x_assum $ qspecl_then [`va`, `mo`] assume_tac \\ gvs [] + \\ unabbrev_all_tac \\ gvs [adjust_bv_def, SF ETA_ss])) + >- ( + rename1 `state_rel b2 s2 t2` + \\ `s2.clock = t2.clock` by gvs [state_rel_def] \\ gvs [] + \\ `state_rel b2 (dec_clock 1 s2) (dec_clock 1 t2)` by + gvs [state_rel_def, bvlSemTheory.dec_clock_def, dec_clock_def] \\ gvs [] + \\ last_x_assum $ drule_at (Pat `state_rel _ _ _`) + \\ simp [bvlSemTheory.AppUnit_def, compile_exps_def, compile_op_def, + compile_int_def, bvlSemTheory.mk_unit_def] + \\ impl_tac + >- ( + rw [handle_ok_def, aux_code_installed_def] + >- ( + qpat_x_assum `evaluate _ = (_,s2)` assume_tac + \\ drule evaluate_ok \\ rw [] + \\ gvs [state_ok_def, bvlSemTheory.dec_clock_def]) + >- ( + `state_ok s2` by ( + qpat_x_assum `evaluate _ = (_,s2)` assume_tac + \\ drule evaluate_ok \\ rw []) \\ gvs [] + \\ pop_assum mp_tac + \\ rw [state_ok_def] + \\ pop_assum $ qspec_then `ptr` assume_tac \\ gvs []) + >- ( + irule evaluate_global_mono + \\ goal_assum $ drule_at Any \\ gvs [])) + \\ rw [] + \\ gvs [GSYM PULL_FORALL, dec_clock_def] + \\ gvs [GSYM AppUnit_def] + \\ qrefinel [`c'`, `_`, `b2'`] \\ gvs [] + \\ `MAP (adjust_bv b2) env = MAP (adjust_bv b2') env` by ( + full_simp_tac(srw_ss())[MAP_EQ_f] \\ REPEAT STRIP_TAC + \\ MATCH_MP_TAC (GEN_ALL bv_ok_IMP_adjust_bv_eq) + \\ qexists_tac `s2.refs` + \\ full_simp_tac(srw_ss())[EVERY_MEM] \\ RES_TAC + \\ IMP_RES_TAC evaluate_refs_SUBSET + \\ REPEAT STRIP_TAC THEN1 METIS_TAC [bv_ok_SUBSET_IMP]) + \\ gvs [dest_thunk_def, PULL_EXISTS] + \\ rw [] + \\ first_x_assum irule \\ gvs [] + \\ imp_res_tac evaluate_refs_SUBSET \\ metis_tac [SUBSET_THM])) \\ REPEAT STRIP_TAC \\ Cases_on `do_app op (REVERSE a) s5` \\ full_simp_tac(srw_ss())[] \\ TRY( @@ -2534,6 +2955,74 @@ Proof \\ fs [names_ok_def] \\ qpat_x_assum `!n k. _` (qspec_then `0` mp_tac) \\ fs [] \\ fs [EVERY_MEM,FORALL_PROD] \\ metis_tac[]) + \\ Cases_on `∃m. op = ThunkOp (AllocThunk m)` >- ( + rw [] \\ gvs [] + \\ gvs [compile_op_def, evaluate_def, AllCaseEqs(), PULL_EXISTS] + \\ gvs [do_app_def, do_app_aux_def, AllCaseEqs(), PULL_EXISTS] + \\ qabbrev_tac `b3 = ((LEAST ptr. ptr ∉ FDOM s5.refs) =+ + (LEAST ptr. ptr ∉ FDOM (bvi_to_bvl t2).refs)) b2` + \\ qexistsl [`b3`, `c`] \\ gvs [] + \\ qabbrev_tac `x = (LEAST ptr. ptr ∉ FDOM s5.refs)` + \\ qabbrev_tac `y = LEAST ptr. ptr ∉ FDOM (bvi_to_bvl t2).refs` + \\ gvs [] + \\ `x ∉ FDOM s5.refs` by ( + `∃p. (\ptr. ptr ∉ FDOM s5.refs) p` by + (rw [] \\ metis_tac [NUM_NOT_IN_FDOM]) + \\ imp_res_tac whileTheory.LEAST_INTRO \\ gvs []) + \\ `y ∉ FDOM t2.refs` by ( + `∃p. (\ptr. ptr ∉ FDOM t2.refs) p` by + (rw [] \\ metis_tac [NUM_NOT_IN_FDOM]) + \\ imp_res_tac whileTheory.LEAST_INTRO \\ gvs []) + \\ gvs [] + \\ gvs [bvlSemTheory.do_app_def, AllCaseEqs(), PULL_EXISTS] + \\ rw [adjust_bv_def] + \\ `MAP (adjust_bv b3) env = MAP (adjust_bv b2) env` by ( + gvs [MAP_EQ_f] \\ rpt strip_tac + \\ match_mp_tac (GEN_ALL bv_ok_IMP_adjust_bv_eq) + \\ qexists_tac `s5.refs` + \\ gvs [EVERY_MEM] \\ res_tac + \\ imp_res_tac evaluate_refs_SUBSET + \\ rpt strip_tac >- metis_tac [bv_ok_SUBSET_IMP] + \\ qunabbrev_tac `b3` \\ gvs [APPLY_UPDATE_THM] + \\ rw [] \\ gvs []) + \\ `adjust_bv b2 v = adjust_bv b3 v` by ( + match_mp_tac (GEN_ALL bv_ok_IMP_adjust_bv_eq) + \\ qexists `s5.refs` + \\ imp_res_tac evaluate_ok \\ gvs [] + \\ qunabbrev_tac `b3` \\ gvs [APPLY_UPDATE_THM] + \\ rw [] \\ gvs []) + \\ gvs [] + \\ conj_tac >- (qunabbrev_tac `b3` \\ rw []) + \\ reverse conj_tac >- ( + rpt strip_tac \\ unabbrev_all_tac + \\ gvs [APPLY_UPDATE_THM] \\ rw [] + \\ imp_res_tac evaluate_refs_SUBSET + \\ gvs [SUBSET_DEF]) + \\ gvs [bvl_to_bvi_def, bvi_to_bvl_def] + \\ qmatch_goalsub_abbrev_tac `state_rel _ _ tt` + \\ `tt = t2 with refs := t2.refs |+ (b3 x,Thunk m (adjust_bv b2 v))` by ( + unabbrev_all_tac \\ gvs [state_component_equality]) + \\ simp [Abbr `tt`, Abbr `b3`] + \\ irule state_rel_add_thunk \\ gvs [] + \\ imp_res_tac evaluate_ok) + \\ Cases_on `∃m. op = ThunkOp (UpdateThunk m)` \\ gvs [] >- ( + rw [] \\ gvs [] + \\ gvs [compile_op_def, evaluate_def, AllCaseEqs(), PULL_EXISTS] + \\ gvs [do_app_def, do_app_aux_def, AllCaseEqs(), PULL_EXISTS] + \\ goal_assum drule + \\ gvs [bvlSemTheory.do_app_def, AllCaseEqs(), PULL_EXISTS] + \\ Cases_on `a` \\ gvs [adjust_bv_def] + \\ drule_all state_rel_FLOOKUP_Thunk \\ rw [] + \\ simp [bvl_to_bvi_def, bvi_to_bvl_def] + \\ qmatch_goalsub_abbrev_tac `state_rel _ _ tt` + \\ `tt = t2 with refs := t2.refs |+ (b2 ptr,Thunk m (adjust_bv b2 h))` by ( + unabbrev_all_tac \\ gvs [state_component_equality]) + \\ qunabbrev_tac `tt` \\ gvs [] + \\ irule state_rel_update_thunk \\ gvs [] + \\ imp_res_tac evaluate_ok \\ gvs [FLOOKUP_DEF]) + \\ `∀thunk_op. op ≠ ThunkOp thunk_op` by ( + qx_gen_tac `t` \\ Cases_on `t` \\ gvs []) + \\ gvs [] \\ Cases_on `?i. op = IntOp (Const i)` \\ full_simp_tac(srw_ss())[] THEN1 (note_tac "Op: Const" \\ CONV_TAC SWAP_EXISTS_CONV \\ Q.EXISTS_TAC `b2` \\ CONV_TAC SWAP_EXISTS_CONV \\ Q.EXISTS_TAC `c` @@ -3272,7 +3761,8 @@ Proof \\ simp[MAP_EQ_f] \\ rw[] \\ fs[EVERY_MEM] \\ match_mp_tac (GEN_ALL bv_ok_IMP_adjust_bv_eq) \\ qexists_tac `s5.refs` \\ simp[APPLY_UPDATE_THM] \\ rw[] - \\ fs[Abbr`a`,LEAST_NOTIN_FDOM] ) + >- fs[Abbr`a`,LEAST_NOTIN_FDOM] + >- fs[Abbr`a'`,LEAST_NOTIN_FDOM]) \\ simp[FLOOKUP_UPDATE,APPLY_UPDATE_THM] \\ ntac 2 strip_tac \\ first_x_assum drule diff --git a/compiler/backend/proofs/clos_callProofScript.sml b/compiler/backend/proofs/clos_callProofScript.sml index a3fe5a04b1..2ed3dec3a8 100644 --- a/compiler/backend/proofs/clos_callProofScript.sml +++ b/compiler/backend/proofs/clos_callProofScript.sml @@ -3153,7 +3153,8 @@ Proof \\ rfs [] \\ fs [code_includes_def]) >~ [`ThunkOp ForceThunk`] >- ( - gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] + gvs [AllCaseEqs(), PULL_EXISTS] + \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] >- ( gvs [v_rel_def] \\ rpt (goal_assum drule \\ gvs []) diff --git a/compiler/backend/proofs/clos_fvsProofScript.sml b/compiler/backend/proofs/clos_fvsProofScript.sml index 48e2787395..ce16c25755 100644 --- a/compiler/backend/proofs/clos_fvsProofScript.sml +++ b/compiler/backend/proofs/clos_fvsProofScript.sml @@ -445,16 +445,18 @@ Proof \\ CCONTR_TAC \\ fs []) \\ IF_CASES_TAC \\ rveq \\ fs [] >- ((* Op = ThunkOp ForceThunk *) - gvs [oneline dest_thunk_def, AllCaseEqs()] - \\ imp_res_tac (cj 1 state_rel_opt_rel_refs) - \\ qpat_x_assum `opt_rel ref_rel _ _` mp_tac - \\ simp [oneline opt_rel_def] \\ CASE_TAC \\ gvs [] - \\ rgs [Once ref_rel_cases] - \\ imp_res_tac state_rel_clocks_eqs \\ gvs [PULL_EXISTS] - \\ imp_res_tac state_rel_dec_clock \\ gvs [] - \\ last_x_assum drule_all \\ rw [AppUnit_def, remove_fvs_def] - \\ goal_assum drule \\ rw [] - \\ drule_all rel_update_thunk \\ rw []) + gvs [AllCaseEqs(), PULL_EXISTS] + \\ ( + gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ imp_res_tac (cj 1 state_rel_opt_rel_refs) + \\ qpat_x_assum `opt_rel ref_rel _ _` mp_tac + \\ simp [oneline opt_rel_def] \\ CASE_TAC \\ gvs [] + \\ rgs [Once ref_rel_cases] + \\ imp_res_tac state_rel_clocks_eqs \\ gvs [PULL_EXISTS] + \\ imp_res_tac state_rel_dec_clock \\ gvs [] + \\ last_x_assum drule_all \\ rw [AppUnit_def, remove_fvs_def] + \\ goal_assum drule \\ rw [] + \\ drule_all rel_update_thunk \\ rw [])) (* op <> Install ∧ op <> ThunkOp ForceThunk *) \\ drule EVERY2_REVERSE \\ disch_tac \\ drule (GEN_ALL do_app_lemma) diff --git a/compiler/backend/proofs/clos_interpProofScript.sml b/compiler/backend/proofs/clos_interpProofScript.sml index b75bbf87e2..b3413cb4ea 100644 --- a/compiler/backend/proofs/clos_interpProofScript.sml +++ b/compiler/backend/proofs/clos_interpProofScript.sml @@ -1050,7 +1050,8 @@ Proof \\ gvs [FUPDATE_LIST] \\ gvs [AllCaseEqs()]) >~ [`ThunkOp ForceThunk`] >- ( - gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] + gvs [AllCaseEqs()] + \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] \\ qrefine `ck + ck'` \\ gvs [] \\ `∀ck'. evaluate (xs,env,t1 with clock := ck + (ck' + t1.clock)) = (Rval [RefPtr v0 ptr],t2 with clock := ck' + t2.clock)` by ( @@ -1064,10 +1065,11 @@ Proof \\ gvs [GSYM PULL_FORALL] \\ impl_tac >- (imp_res_tac evaluate_clock \\ gvs []) - \\ disch_then $ qspec_then `[f]` mp_tac \\ gvs [dec_clock_def] + \\ disch_then $ qspec_then `[v]` mp_tac \\ gvs [dec_clock_def] \\ disch_then $ qspec_then `dec_clock 1 t2` mp_tac \\ gvs [dec_clock_def] \\ impl_tac - >- gvs [state_rel_def] \\ rw [] + >- gvs [state_rel_def] + \\ rw [] \\ goal_assum drule \\ gvs [] \\ imp_res_tac state_rel_update_thunk \\ rw [])) QED diff --git a/compiler/backend/proofs/clos_knownProofScript.sml b/compiler/backend/proofs/clos_knownProofScript.sml index 48dfb5ec5c..819b2e9613 100644 --- a/compiler/backend/proofs/clos_knownProofScript.sml +++ b/compiler/backend/proofs/clos_knownProofScript.sml @@ -1036,7 +1036,6 @@ Proof THEN1 ( gvs [oneline dest_thunk_def, AllCaseEqs()] - >- goal_assum drule \\ TRY ( qexists `n` \\ gvs [SET_OF_BAG_UNION] \\ metis_tac [mglobals_extend_SUBSET, UNION_ASSOC, SUBSET_UNION]) @@ -1047,7 +1046,7 @@ Proof \\ metis_tac [mglobals_extend_SUBSET, UNION_ASSOC, SUBSET_UNION]) >- ( gvs [Once AppUnit_def] - \\ `vsgc_free f` by ( + \\ `vsgc_free v` by ( gvs [ssgc_free_def] \\ rpt (first_x_assum drule \\ rw [])) \\ gvs [dec_clock_def] \\ qexists `n' + n` @@ -1065,7 +1064,7 @@ Proof \\ metis_tac [UNION_ASSOC, UNION_COMM, SUBSET_UNION]) >- ( gvs [Once AppUnit_def] - \\ `vsgc_free f` by ( + \\ `vsgc_free v` by ( gvs [ssgc_free_def] \\ rpt (first_x_assum drule \\ rw [])) \\ gvs [dec_clock_def] \\ conj_tac >- (drule_all update_thunk_ssgc_free \\ gvs []) @@ -1084,7 +1083,7 @@ Proof \\ metis_tac [UNION_ASSOC, UNION_COMM, SUBSET_UNION]) >- ( gvs [Once AppUnit_def] - \\ `vsgc_free f` by ( + \\ `vsgc_free v` by ( gvs [ssgc_free_def] \\ rpt (first_x_assum drule \\ rw [])) \\ gvs [dec_clock_def] \\ qexists `n' + n` @@ -3149,7 +3148,7 @@ Proof \\ ( gvs [oneline store_thunk_def, AllCaseEqs(), PULL_EXISTS] \\ TRY ( - rename1 `FLOOKUP s2.refs pf = NONE ∨ _` + rename1 `FLOOKUP s2.refs pf = SOME _ ∧ _` \\ qpat_x_assum `FLOOKUP s1.refs pf = _` assume_tac \\ drule_all (cj 1 state_rel_opt_rel_refs) \\ rw [OPTREL_def] \\ gvs []) \\ TRY ( @@ -3731,13 +3730,13 @@ Proof \\ first_x_assum drule \\ rw []) \\ gvs []) >- ( `∃w. FLOOKUP t.refs ptr = SOME (Thunk NotEvaluated w) ∧ - v_rel c (next_g s) f w` by ( + v_rel c (next_g s) v w` by ( gvs [state_rel_def, fmap_rel_def, FLOOKUP_DEF] \\ first_x_assum drule \\ rw []) \\ gvs [] \\ `t.clock = 0` by gvs [state_rel_def] \\ gvs []) >- ( `∃w. FLOOKUP t.refs ptr = SOME (Thunk NotEvaluated w) ∧ - v_rel c (next_g s1) f w` by ( + v_rel c (next_g s1) v w` by ( gvs [state_rel_def, fmap_rel_def, FLOOKUP_DEF] \\ first_x_assum drule \\ rw []) \\ gvs [PULL_EXISTS] \\ simp [GSYM PULL_EXISTS] \\ rw [] @@ -3757,7 +3756,7 @@ Proof \\ gvs [clos_opTheory.SmartOp_def, clos_opTheory.SmartOp'_def]) \\ gvs [] \\ disch_then drule \\ gvs [] - \\ disch_then $ qspec_then `[f]` mp_tac \\ gvs [] + \\ disch_then $ qspec_then `[v]` mp_tac \\ gvs [] \\ disch_then $ qspecl_then [`[w]`, `[]`] mp_tac \\ gvs [] \\ impl_tac >- ( rw [] @@ -3802,8 +3801,8 @@ Proof >- ( gvs [AppUnit_def, fv_max_def] \\ rw [] \\ CCONTR_TAC - \\ qmatch_asmsub_abbrev_tac `fv1 v exp` - \\ `fv v [exp] ⇔ v = 0` by (unabbrev_all_tac \\ gvs [fv_def]) + \\ qmatch_asmsub_abbrev_tac `fv1 v' exp` + \\ `fv v' [exp] ⇔ v' = 0` by (unabbrev_all_tac \\ gvs [fv_def]) \\ gvs []) >- gvs [next_g_def] >- ( @@ -3820,7 +3819,7 @@ Proof \\ drule_all rel_update_thunk \\ rw []) >- ( `∃w. FLOOKUP t.refs ptr = SOME (Thunk NotEvaluated w) ∧ - v_rel c (next_g s1) f w` by ( + v_rel c (next_g s1) v w` by ( gvs [state_rel_def, fmap_rel_def, FLOOKUP_DEF] \\ first_x_assum drule \\ rw []) \\ gvs [PULL_EXISTS] \\ simp [GSYM PULL_EXISTS] \\ rw [] @@ -3839,7 +3838,7 @@ Proof \\ gvs [clos_opTheory.SmartOp_def, clos_opTheory.SmartOp'_def]) \\ gvs [] \\ disch_then drule \\ gvs [] - \\ disch_then $ qspec_then `[f]` mp_tac \\ gvs [] + \\ disch_then $ qspec_then `[v]` mp_tac \\ gvs [] \\ disch_then $ qspecl_then [`[w]`, `[]`] mp_tac \\ gvs [] \\ impl_tac >- ( rw [] @@ -3884,8 +3883,8 @@ Proof >- ( gvs [AppUnit_def, fv_max_def] \\ rw [] \\ CCONTR_TAC - \\ qmatch_asmsub_abbrev_tac `fv1 v exp` - \\ `fv v [exp] ⇔ v = 0` by (unabbrev_all_tac \\ gvs [fv_def]) + \\ qmatch_asmsub_abbrev_tac `fv1 v' exp` + \\ `fv v' [exp] ⇔ v' = 0` by (unabbrev_all_tac \\ gvs [fv_def]) \\ gvs []) >- gvs [next_g_def] >- ( diff --git a/compiler/backend/proofs/clos_letopProofScript.sml b/compiler/backend/proofs/clos_letopProofScript.sml index 75dcf758d7..d43fd0f48f 100644 --- a/compiler/backend/proofs/clos_letopProofScript.sml +++ b/compiler/backend/proofs/clos_letopProofScript.sml @@ -512,16 +512,18 @@ Proof \\ fs []) \\ IF_CASES_TAC \\ rveq \\ fs [] THEN1 (* Op = ThunkOp ForceThunk *) - (gvs [oneline dest_thunk_def, AllCaseEqs()] - \\ imp_res_tac (cj 1 state_rel_opt_rel_refs) - \\ qpat_x_assum `opt_rel ref_rel _ _` mp_tac - \\ simp [oneline opt_rel_def] \\ CASE_TAC \\ gvs [PULL_EXISTS] - \\ rgs [Once ref_rel_cases] - \\ imp_res_tac state_rel_clocks_eqs \\ gvs [PULL_EXISTS] - \\ imp_res_tac state_rel_dec_clock \\ gvs [] - \\ last_x_assum drule_all \\ rw [AppUnit_def, let_op_def] - \\ goal_assum drule \\ rw [] - \\ drule_all rel_update_thunk \\ rw []) + (gvs [AllCaseEqs()] + \\ ( + gvs [oneline dest_thunk_def, AllCaseEqs()] + \\ imp_res_tac (cj 1 state_rel_opt_rel_refs) + \\ qpat_x_assum `opt_rel ref_rel _ _` mp_tac + \\ simp [oneline opt_rel_def] \\ CASE_TAC \\ gvs [PULL_EXISTS] + \\ rgs [Once ref_rel_cases] + \\ imp_res_tac state_rel_clocks_eqs \\ gvs [PULL_EXISTS] + \\ imp_res_tac state_rel_dec_clock \\ gvs [] + \\ last_x_assum drule_all \\ rw [AppUnit_def, let_op_def] + \\ goal_assum drule \\ rw [] + \\ drule_all rel_update_thunk \\ rw [])) (* op <> Install /\ op <> ThunkOp ForceThunk *) \\ drule EVERY2_REVERSE \\ disch_tac \\ drule (GEN_ALL do_app_lemma) diff --git a/compiler/backend/proofs/clos_mtiProofScript.sml b/compiler/backend/proofs/clos_mtiProofScript.sml index 1d539635bc..97f46e6648 100644 --- a/compiler/backend/proofs/clos_mtiProofScript.sml +++ b/compiler/backend/proofs/clos_mtiProofScript.sml @@ -772,6 +772,7 @@ Proof \\ Cases_on `opp = ThunkOp ForceThunk` \\ gvs [] \\ rveq >- ( Cases_on `res1` \\ gvs [] + \\ gvs [AllCaseEqs()] \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] \\ drule_all (cj 2 state_rel_opt_rel_refs) \\ rw [OPTREL_def] \\ rgs [Once ref_rel_cases] @@ -781,7 +782,7 @@ Proof `state_rel (dec_clock 1 s2) (dec_clock 1 s')` by ( gvs [state_rel_def, dec_clock_def]) \\ gvs [] \\ last_x_assum $ drule_at (Pat `state_rel _ _`) \\ gvs [] - \\ disch_then $ qspecl_then [`[AppUnit (Var None 0)]`, `v`] mp_tac + \\ disch_then $ qspecl_then [`[AppUnit (Var None 0)]`, `v'`] mp_tac \\ gvs [] \\ impl_tac >- gvs [state_rel_def, dec_clock_def, AppUnit_def, no_mti_def, intro_multi_def, collect_apps_def] diff --git a/compiler/backend/proofs/clos_numberProofScript.sml b/compiler/backend/proofs/clos_numberProofScript.sml index c44093b062..e02077c42a 100644 --- a/compiler/backend/proofs/clos_numberProofScript.sml +++ b/compiler/backend/proofs/clos_numberProofScript.sml @@ -825,6 +825,7 @@ Proof \\ imp_res_tac state_rel_max_app \\ gvs [] \\ imp_res_tac evaluate_const \\ gvs [] \\ imp_res_tac state_rel_clock \\ gvs [] + \\ gvs [AllCaseEqs()] \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] \\ rgs [Once v_rel_cases] \\ imp_res_tac state_rel_refs \\ gvs [fmap_rel_def, FLOOKUP_DEF] diff --git a/compiler/backend/proofs/clos_ticksProofScript.sml b/compiler/backend/proofs/clos_ticksProofScript.sml index 554c36d78b..3e8bec1a60 100644 --- a/compiler/backend/proofs/clos_ticksProofScript.sml +++ b/compiler/backend/proofs/clos_ticksProofScript.sml @@ -641,6 +641,7 @@ Proof \\ `∀ck'. evaluate (es,env1,s1 with clock := ck + (ck' + s1.clock)) = (Rval a,s2 with clock := s2.clock + ck')` by ( rw [] \\ drule evaluate_add_clock \\ gvs []) \\ gvs [] + \\ gvs [AllCaseEqs()] \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] \\ TRY (qexists `0` \\ gvs [state_rel_def] \\ NO_TAC) \\ imp_res_tac (cj 2 state_rel_opt_rel_refs) diff --git a/compiler/backend/proofs/clos_to_bvlProofScript.sml b/compiler/backend/proofs/clos_to_bvlProofScript.sml index 95499d2943..696a712a55 100644 --- a/compiler/backend/proofs/clos_to_bvlProofScript.sml +++ b/compiler/backend/proofs/clos_to_bvlProofScript.sml @@ -1097,6 +1097,7 @@ End Definition ref_rel_def: (ref_rel R (closSem$ValueArray vs) (bvlSem$ValueArray ws) ⇔ LIST_REL R vs ws) ∧ + (ref_rel R (closSem$Thunk m1 v) (bvlSem$Thunk m2 w) ⇔ m1 = m2 ∧ R v w) ∧ (ref_rel R (ByteArray as) (ByteArray g bs) ⇔ ~g ∧ as = bs) ∧ (ref_rel _ _ _ = F) End @@ -1104,6 +1105,7 @@ val _ = export_rewrites["ref_rel_def"]; Theorem ref_rel_simp[simp]: (ref_rel R (ValueArray vs) y ⇔ ∃ws. y = ValueArray ws ∧ LIST_REL R vs ws) ∧ + (ref_rel R (Thunk m v) y ⇔ ∃w. y = Thunk m w ∧ R v w) ∧ (ref_rel R (ByteArray bs) y ⇔ y = ByteArray F bs) Proof Cases_on`y`>>simp[ref_rel_def] >> srw_tac[][EQ_IMP_THM] @@ -1365,27 +1367,37 @@ Proof >- ( pop_assum mp_tac \\ rw[] \\ rw[] >- ( - Cases_on`v` \\ fs[ref_rel_def] \\ + Cases_on`v` \\ fs[ref_rel_def] + >- ( + match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) \\ + ONCE_REWRITE_TAC[CONJ_COMM] >> + first_assum(match_exists_tac o concl) >> simp[] >> + rpt strip_tac >> + match_mp_tac v_rel_UPDATE_REF >> + fs[IN_FRANGE_FLOOKUP] + \\ asm_exists_tac \\ fs[]) + >- ( + match_mp_tac v_rel_UPDATE_REF + \\ gvs [IN_FRANGE_FLOOKUP] + \\ goal_assum drule)) + \\ res_tac \\ fs[] + \\ rw[] \\ fs[] + >- ( + fs[INJ_DEF,FLOOKUP_DEF] + \\ metis_tac[] ) + \\ Cases_on`x` \\ fs[ref_rel_def] \\ rw[] + >- ( match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) \\ ONCE_REWRITE_TAC[CONJ_COMM] >> first_assum(match_exists_tac o concl) >> simp[] >> rpt strip_tac >> match_mp_tac v_rel_UPDATE_REF >> fs[IN_FRANGE_FLOOKUP] - \\ asm_exists_tac \\ fs[] ) - \\ res_tac \\ fs[] - \\ rw[] \\ fs[] + \\ asm_exists_tac \\ fs[]) >- ( - fs[INJ_DEF,FLOOKUP_DEF] - \\ metis_tac[] ) - \\ Cases_on`x` \\ fs[ref_rel_def] \\ rw[] \\ - match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) \\ - ONCE_REWRITE_TAC[CONJ_COMM] >> - first_assum(match_exists_tac o concl) >> simp[] >> - rpt strip_tac >> - match_mp_tac v_rel_UPDATE_REF >> - fs[IN_FRANGE_FLOOKUP] - \\ asm_exists_tac \\ fs[] ) + match_mp_tac v_rel_UPDATE_REF + \\ gvs [IN_FRANGE_FLOOKUP] + \\ goal_assum drule)) QED Theorem state_rel_NEW_REF: @@ -1408,13 +1420,17 @@ Proof >- ( fs[SUBSET_DEF] ) \\ res_tac \\ rw[] >- fs[FLOOKUP_DEF] - \\ Cases_on`x` \\ fs[ref_rel_def] \\ rw[] \\ - match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) \\ - ONCE_REWRITE_TAC[CONJ_COMM] >> - first_assum(match_exists_tac o concl) >> simp[] >> - rpt strip_tac >> - match_mp_tac v_rel_NEW_REF >> - fs[IN_FRANGE_FLOOKUP] + \\ Cases_on`x` \\ fs[ref_rel_def] \\ rw[] + >- ( + match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) \\ + ONCE_REWRITE_TAC[CONJ_COMM] >> + first_assum(match_exists_tac o concl) >> simp[] >> + rpt strip_tac >> + match_mp_tac v_rel_NEW_REF >> + fs[IN_FRANGE_FLOOKUP]) + >- ( + match_mp_tac v_rel_NEW_REF + \\ gvs [IN_FRANGE_FLOOKUP]) QED (* semantic functions respect relation *) @@ -1528,7 +1544,8 @@ Theorem do_app[local]: (op ≠ MemOp RefArray) ∧ (∀f. op ≠ MemOp (RefByte f)) ∧ (op ≠ MemOp UpdateByte) ∧ (op ≠ MemOp FromListByte) ∧ op ≠ MemOp ConcatByteVec ∧ (∀b. op ≠ MemOp (CopyByte b)) ∧ (∀c. op ≠ BlockOp (Constant c)) ∧ - (∀n. op ≠ (FFI n)) ==> + (∀n. op ≠ (FFI n)) ∧ + (∀t. op ≠ (ThunkOp t)) ==> ?w t2. (do_app (compile_op op) ys t1 = Rval (w,t2)) /\ v_rel s1.max_app f t1.refs t1.code v w /\ @@ -1567,7 +1584,6 @@ Proof (srw_tac[][closSemTheory.do_app_def] \\ fs [] \\ every_case_tac \\ gvs [bvlSemTheory.do_app_def,v_rel_SIMP]) \\ Cases_on `op = Install` THEN1 fs[closSemTheory.do_app_def] - \\ Cases_on `∃t. op = ThunkOp t` THEN1 cheat \\ Cases_on `op = BlockOp Equal` THEN1 (srw_tac[][closSemTheory.do_app_def,bvlSemTheory.do_app_def, bvlSemTheory.do_eq_def] @@ -3354,12 +3370,32 @@ Proof rw[FLOOKUP_UPDATE] \\ first_x_assum drule \\ rw[] \\ simp[] \\ rw[] >- ( fs[FLOOKUP_DEF] \\ METIS_TAC[LEAST_NOTIN_FDOM] ) \\ - Cases_on`x` \\ fs[] \\ - match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) >> - ONCE_REWRITE_TAC[CONJ_COMM] >> - asm_exists_tac \\ fs[] \\ rw[] \\ - match_mp_tac v_rel_NEW_REF \\ - simp[LEAST_NOTIN_FDOM] + Cases_on`x` \\ fs[] + >- ( + match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) >> + ONCE_REWRITE_TAC[CONJ_COMM] >> + asm_exists_tac \\ fs[] \\ rw[] \\ + match_mp_tac v_rel_NEW_REF \\ + simp[LEAST_NOTIN_FDOM]) + >- (match_mp_tac v_rel_NEW_REF \\ simp [LEAST_NOTIN_FDOM]) +QED + +Theorem rel_dest_thunk: + state_rel f s t ∧ + LIST_REL (v_rel s.max_app f t.refs t.code) vs ys ∧ + dest_thunk vs s.refs = IsThunk m r1 ⇒ + ∃r2. dest_thunk ys t.refs = IsThunk m r2 ∧ + v_rel s.max_app f t.refs t.code r1 r2 +Proof + rw [] + \\ gvs [oneline closSemTheory.dest_thunk_def, oneline dest_thunk_def, + AllCaseEqs(), PULL_EXISTS] + \\ ( + qpat_x_assum `v_rel _ _ _ _ (RefPtr _ _) y` mp_tac + \\ reverse $ rw [Once v_rel_cases] + >- gvs [add_args_F] + >- rgs [Once cl_rel_cases] + \\ drule_all state_rel_refs_lookup \\ rw [] \\ gvs []) QED Theorem compile_exps_correct: @@ -3723,8 +3759,10 @@ Proof \\ rename1 `_ x2 x3` \\ Cases_on `x3` \\ fs [] \\ Cases_on `x2` \\ fs [ref_rel_def] - \\ first_x_assum (fn th => mp_tac th \\ match_mp_tac LIST_REL_mono) - \\ rpt strip_tac \\ match_mp_tac v_rel_union \\ simp []) + >- ( + first_x_assum (fn th => mp_tac th \\ match_mp_tac LIST_REL_mono) + \\ rpt strip_tac \\ match_mp_tac v_rel_union \\ simp []) + >- (match_mp_tac v_rel_union \\ simp [])) THEN1 (fs [compile_oracle_inv_def] \\ fs [FUN_EQ_THM,shift_seq_def] @@ -3935,7 +3973,134 @@ Proof \\ disj2_tac \\ CCONTR_TAC \\ fs [] ) \\ srw_tac[][] - \\ Cases_on `op = ThunkOp ForceThunk` THEN1 cheat + \\ Cases_on `op = ThunkOp ForceThunk` >- ( + gvs [closSemTheory.evaluate_def, compile_exps_def] + \\ pairarg_tac \\ gvs [evaluate_def] + \\ gvs [AllCaseEqs(), PULL_EXISTS] + >- ( + first_x_assum drule_all \\ rw [] \\ gvs [] + \\ goal_assum drule \\ gvs [] + \\ imp_res_tac evaluate_const \\ gvs [] + \\ drule (GEN_ALL rel_dest_thunk) \\ simp [] + \\ disch_then drule \\ rw [] \\ gvs [] + \\ goal_assum drule \\ gvs []) + >- ( + first_x_assum drule_all \\ rw [] \\ gvs [] + \\ goal_assum drule \\ gvs [] + \\ imp_res_tac evaluate_const \\ gvs [] + \\ drule (GEN_ALL rel_dest_thunk) \\ simp [] + \\ disch_then drule \\ rw [] \\ gvs [] + \\ goal_assum drule \\ gvs []) + >- ( + first_x_assum drule_all \\ rw [] \\ gvs [] + \\ `∀ck'. evaluate (c1,env'',t1 with clock := ck' + ck + s.clock) = + (Rval v', t2 with clock := t2.clock + ck')` by ( + rw [] \\ drule evaluate_add_clock \\ rw [inc_clock_def]) \\ gvs [] + \\ qrefine `ck + ck'` \\ gvs [] + \\ imp_res_tac evaluate_const \\ gvs [] + \\ drule (GEN_ALL rel_dest_thunk) \\ simp [] + \\ disch_then drule \\ rw [] \\ gvs [PULL_EXISTS] + \\ `state_rel f2 (dec_clock 1 s') (dec_clock 1 t2)` by ( + gvs [state_rel_def, closSemTheory.dec_clock_def, dec_clock_def] + \\ rw [] \\ first_x_assum drule \\ rw []) \\ gvs [] + \\ first_x_assum $ drule_at (Pat `state_rel _ _`) + \\ simp [closSemTheory.AppUnit_def, compile_exps_def] + \\ disch_then $ qspecl_then [`aux1`, `[r2]`] mp_tac + \\ impl_tac >- ( + gvs [closSemTheory.dec_clock_def] \\ rw [] + >- ( + drule_all (GEN_ALL compile_exps_IMP_code_installed) \\ rw [] + \\ drule evaluate_mono \\ rw [] + \\ gvs [code_installed_def, subspt_def, EVERY_EL] \\ rw [] + \\ pairarg_tac \\ gvs [] + \\ first_x_assum drule \\ rw [] + \\ gvs [domain_lookup]) + >- gvs [env_rel_def]) + \\ rw [] \\ simp [] + \\ gvs [closSemTheory.dec_clock_def, dec_clock_def] + \\ qrefinel [`_`, `f2'`, `v''`, `t2'`] \\ rw [GSYM PULL_EXISTS] + >- ( + gvs [AppUnit_def] + \\ gvs [evaluate_def, clos_tag_shift_def, mk_cl_call_def, do_app_def] + \\ Cases_on `r2` + \\ gvs [AllCaseEqs(), PULL_EXISTS, mk_unit_def, evaluate_def, + generic_app_fn_location_def] + \\ goal_assum drule \\ gvs []) + \\ gvs [oneline closSemTheory.update_thunk_def, oneline update_thunk_def, + AllCaseEqs(), PULL_EXISTS] + \\ qpat_x_assum `v_rel _ _ _ _ _ y` mp_tac + \\ reverse $ rw [Once v_rel_cases] + >- gvs [add_args_F] + >- gvs [Once cl_rel_cases] + \\ gvs [closSemTheory.store_thunk_def, store_thunk_def, AllCaseEqs(), + PULL_EXISTS] + \\ gvs [dest_thunk_def, closSemTheory.dest_thunk_def, AllCaseEqs()] + \\ reverse $ rw [GSYM PULL_EXISTS] + >- ( + `r2' ∈ (FRANGE f2')` by ( + gvs [TO_FLOOKUP] \\ first_x_assum drule \\ rw [SF SFY_ss]) + \\ gvs [FDIFF_FUPDATE] \\ rw [] + \\ imp_res_tac SUBMAP_TRANS) + >- imp_res_tac SUBMAP_TRANS + >- ( + irule state_rel_UPDATE_REF \\ rw [] + \\ gvs [FLOOKUP_DEF, SUBMAP_DEF]) + >- ( + irule v_rel_UPDATE_REF \\ rw [] + \\ gvs [FLOOKUP_DEF] + \\ irule (iffRL IN_FRANGE) + \\ qexists `ptr` \\ gvs [SUBMAP_DEF]) + >- ( + drule_then drule (GEN_ALL state_rel_refs_lookup) \\ rw [] + \\ gvs [FLOOKUP_DEF, SUBMAP_DEF]) + \\ gvs [oneline closSemTheory.dest_thunk_def, oneline dest_thunk_def, + AllCaseEqs(), PULL_EXISTS] + \\ qpat_x_assum `v_rel _ _ _ _ _ y'` mp_tac + \\ rw [Once v_rel_cases] + \\ drule_all state_rel_refs_lookup \\ rw [] \\ gvs []) + >- ( + first_x_assum drule_all \\ rw [] \\ gvs [] + \\ `∀ck'. evaluate (c1,env'',t1 with clock := ck' + ck + s.clock) = + (Rval v', t2 with clock := t2.clock + ck')` by ( + rw [] \\ drule evaluate_add_clock \\ rw [inc_clock_def]) \\ gvs [] + \\ qrefine `ck + ck'` \\ gvs [] + \\ imp_res_tac evaluate_const \\ gvs [] + \\ drule (GEN_ALL rel_dest_thunk) \\ simp [] + \\ disch_then drule \\ rw [] \\ gvs [PULL_EXISTS] + \\ `state_rel f2 (dec_clock 1 s') (dec_clock 1 t2)` by ( + gvs [state_rel_def, closSemTheory.dec_clock_def, dec_clock_def] + \\ rw [] \\ first_x_assum drule \\ rw []) \\ gvs [] + \\ first_x_assum $ drule_at (Pat `state_rel _ _`) + \\ simp [closSemTheory.AppUnit_def, compile_exps_def] + \\ disch_then $ qspecl_then [`aux1`, `[r2]`] mp_tac + \\ impl_tac >- ( + gvs [closSemTheory.dec_clock_def] \\ rw [] + >- ( + drule_all (GEN_ALL compile_exps_IMP_code_installed) \\ rw [] + \\ drule evaluate_mono \\ rw [] + \\ gvs [code_installed_def, subspt_def, EVERY_EL] \\ rw [] + \\ pairarg_tac \\ gvs [] + \\ first_x_assum drule \\ rw [] + \\ gvs [domain_lookup]) + >- gvs [env_rel_def]) + \\ rw [] \\ simp [] + \\ gvs [closSemTheory.dec_clock_def, dec_clock_def] + \\ rpt (goal_assum $ drule_at Any \\ gvs []) + \\ qrefinel [`_`, `Rerr e'`, `t2'`] \\ rw [GSYM PULL_EXISTS] + >- ( + gvs [AppUnit_def] + \\ gvs [evaluate_def, clos_tag_shift_def, mk_cl_call_def, do_app_def] + \\ rpt ( + CASE_TAC + \\ gvs [mk_unit_def, evaluate_def, generic_app_fn_location_def]) + \\ gvs [AllCaseEqs()] + \\ qexists `ck'` \\ gvs []) + \\ imp_res_tac SUBMAP_TRANS) + >- ( + first_x_assum drule_all \\ rw [] \\ gvs [] + \\ goal_assum drule \\ rw [PULL_EXISTS] + \\ goal_assum drule \\ gvs [])) + \\ srw_tac[][] \\ full_simp_tac(srw_ss())[cEval_def,compile_exps_def] \\ SRW_TAC [] [bEval_def] \\ `?p. evaluate (xs,env,s) = p` by full_simp_tac(srw_ss())[] \\ PairCases_on `p` \\ full_simp_tac(srw_ss())[] \\ `?cc. compile_exps s.max_app xs aux1 = cc` by full_simp_tac(srw_ss())[] \\ PairCases_on `cc` \\ full_simp_tac(srw_ss())[] @@ -3950,6 +4115,11 @@ Proof \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] \\ fs [] \\ qexists_tac `ck` >> simp[] + \\ `compile_op op ≠ ThunkOp ForceThunk` by ( + CCONTR_TAC \\ gvs [] + \\ gvs [oneline compile_op_def, AllCaseEqs()] + \\ gvs [oneline compile_const_def, AllCaseEqs()] + \\ pairarg_tac \\ gvs []) \\ reverse(Cases_on `do_app op (REVERSE a) p1`) \\ full_simp_tac(srw_ss())[] >- ( srw_tac[][] >> first_x_assum(mp_tac o INST_TYPE[beta|->gamma] o MATCH_MP @@ -4033,11 +4203,15 @@ Proof \\ RES_TAC \\ full_simp_tac(srw_ss())[] \\ `qq <> m` by (REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[FLOOKUP_DEF] \\ SRW_TAC [] []) \\ Cases_on`x`>>full_simp_tac(srw_ss())[] - \\ Q.PAT_X_ASSUM `LIST_REL (v_rel _ f2 t2.refs t2.code) xs' ys'` MP_TAC - \\ MATCH_MP_TAC listTheory.LIST_REL_mono - \\ REPEAT STRIP_TAC - \\ MATCH_MP_TAC v_rel_NEW_REF \\ full_simp_tac(srw_ss())[] - \\ MATCH_MP_TAC v_rel_NEW_F \\ full_simp_tac(srw_ss())[]) + >- ( + Q.PAT_X_ASSUM `LIST_REL (v_rel _ f2 t2.refs t2.code) xs' ys'` MP_TAC + \\ MATCH_MP_TAC listTheory.LIST_REL_mono + \\ REPEAT STRIP_TAC + \\ MATCH_MP_TAC v_rel_NEW_REF \\ full_simp_tac(srw_ss())[] + \\ MATCH_MP_TAC v_rel_NEW_F \\ full_simp_tac(srw_ss())[]) + >- ( + MATCH_MP_TAC v_rel_NEW_REF \\ full_simp_tac(srw_ss())[] + \\ MATCH_MP_TAC v_rel_NEW_F \\ full_simp_tac(srw_ss())[])) \\ conj_tac >- (full_simp_tac(srw_ss())[SUBMAP_DEF,FAPPLY_FUPDATE_THM] \\ SRW_TAC [][] \\ METIS_TAC [] ) >> full_simp_tac(srw_ss())[SUBMAP_DEF,FAPPLY_FUPDATE_THM,FDIFF_def,DRESTRICT_DEF] >> srw_tac[][] >> METIS_TAC[]) @@ -4093,11 +4267,15 @@ Proof \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] \\ qmatch_rename_tac`ref_rel _ ref _` \\ Cases_on`ref` >> full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] - \\ Q.PAT_X_ASSUM `LIST_REL pp xs' ws''` MP_TAC - \\ MATCH_MP_TAC listTheory.LIST_REL_mono - \\ REPEAT STRIP_TAC - \\ MATCH_MP_TAC v_rel_UPDATE_REF \\ full_simp_tac(srw_ss())[] - \\ full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC []) + >- ( + Q.PAT_X_ASSUM `LIST_REL pp xs' ws''` MP_TAC + \\ MATCH_MP_TAC listTheory.LIST_REL_mono + \\ REPEAT STRIP_TAC + \\ MATCH_MP_TAC v_rel_UPDATE_REF \\ full_simp_tac(srw_ss())[] + \\ full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC []) + >- ( + MATCH_MP_TAC v_rel_UPDATE_REF \\ full_simp_tac(srw_ss())[] + \\ full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC [])) \\ `m IN FRANGE f2` by (full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC []) \\ full_simp_tac(srw_ss())[SUBMAP_DEF,FDIFF_def,DRESTRICT_DEF,FAPPLY_FUPDATE_THM, add_args_def]) \\ Cases_on `op = MemOp RefArray` \\ full_simp_tac(srw_ss())[] THEN1 ( @@ -4149,16 +4327,23 @@ Proof full_simp_tac(srw_ss())[SUBSET_DEF] >> res_tac >> var_eq_tac >> full_simp_tac(srw_ss())[Abbr`m`,LEAST_NOTIN_FDOM] ) >> - Cases_on`x`>>full_simp_tac(srw_ss())[] >> - match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) >> - ONCE_REWRITE_TAC[CONJ_COMM] >> - first_assum(match_exists_tac o concl) >> simp[] >> - rpt strip_tac >> - match_mp_tac v_rel_NEW_REF >> - reverse conj_tac >- ( - simp[Abbr`pp`,LEAST_NOTIN_FDOM] ) >> - match_mp_tac v_rel_NEW_F >> - simp[Abbr`pp`,Abbr`qq`,LEAST_NOTIN_FDOM] ) >> + Cases_on`x`>>full_simp_tac(srw_ss())[] + >- ( + match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) >> + ONCE_REWRITE_TAC[CONJ_COMM] >> + first_assum(match_exists_tac o concl) >> simp[] >> + rpt strip_tac >> + match_mp_tac v_rel_NEW_REF >> + reverse conj_tac >- ( + simp[Abbr`pp`,LEAST_NOTIN_FDOM] ) >> + match_mp_tac v_rel_NEW_F >> + simp[Abbr`pp`,Abbr`qq`,LEAST_NOTIN_FDOM]) + >- ( + match_mp_tac v_rel_NEW_REF >> + reverse conj_tac >- ( + simp[Abbr`pp`,LEAST_NOTIN_FDOM] ) >> + match_mp_tac v_rel_NEW_F >> + simp[Abbr`pp`,Abbr`qq`,LEAST_NOTIN_FDOM])) >> strip_tac >> var_eq_tac >> simp[] >> simp[LIST_REL_REPLICATE_same] >> srw_tac[][] >> match_mp_tac v_rel_NEW_REF >> @@ -4231,16 +4416,23 @@ Proof full_simp_tac(srw_ss())[SUBSET_DEF] >> res_tac >> var_eq_tac >> full_simp_tac(srw_ss())[Abbr`m`,LEAST_NOTIN_FDOM] ) >> - Cases_on`x`>>full_simp_tac(srw_ss())[] >> - match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) >> - ONCE_REWRITE_TAC[CONJ_COMM] >> - first_assum(match_exists_tac o concl) >> simp[] >> - rpt strip_tac >> - match_mp_tac v_rel_NEW_REF >> - reverse conj_tac >- ( - simp[Abbr`pp`,LEAST_NOTIN_FDOM] ) >> - match_mp_tac v_rel_NEW_F >> - simp[Abbr`pp`,Abbr`qq`,LEAST_NOTIN_FDOM] ) >> + Cases_on`x`>>full_simp_tac(srw_ss())[] + >- ( + match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) >> + ONCE_REWRITE_TAC[CONJ_COMM] >> + first_assum(match_exists_tac o concl) >> simp[] >> + rpt strip_tac >> + match_mp_tac v_rel_NEW_REF >> + reverse conj_tac >- ( + simp[Abbr`pp`,LEAST_NOTIN_FDOM] ) >> + match_mp_tac v_rel_NEW_F >> + simp[Abbr`pp`,Abbr`qq`,LEAST_NOTIN_FDOM]) + >- ( + match_mp_tac v_rel_NEW_REF >> + reverse conj_tac >- ( + simp[Abbr`pp`,LEAST_NOTIN_FDOM] ) >> + match_mp_tac v_rel_NEW_F >> + simp[Abbr`pp`,Abbr`qq`,LEAST_NOTIN_FDOM])) >> strip_tac >> var_eq_tac >> simp[]) >> conj_tac >- ( match_mp_tac SUBMAP_TRANS >> @@ -4291,11 +4483,15 @@ Proof \\ SIMP_TAC std_ss [INJ_DEF,FRANGE_DEF] \\ full_simp_tac(srw_ss())[FLOOKUP_DEF] \\ METIS_TAC []) \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] \\ Cases_on`x` >> full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] - \\ Q.PAT_X_ASSUM `LIST_REL pp xs' ws''` MP_TAC - \\ MATCH_MP_TAC listTheory.LIST_REL_mono - \\ REPEAT STRIP_TAC - \\ MATCH_MP_TAC v_rel_UPDATE_REF \\ full_simp_tac(srw_ss())[] - \\ full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC []) + >- ( + Q.PAT_X_ASSUM `LIST_REL pp xs' ws''` MP_TAC + \\ MATCH_MP_TAC listTheory.LIST_REL_mono + \\ REPEAT STRIP_TAC + \\ MATCH_MP_TAC v_rel_UPDATE_REF \\ full_simp_tac(srw_ss())[] + \\ full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC []) + >- ( + MATCH_MP_TAC v_rel_UPDATE_REF \\ full_simp_tac(srw_ss())[] + \\ full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC [])) \\ `m IN FRANGE f2` by (full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC []) \\ full_simp_tac(srw_ss())[SUBMAP_DEF,FDIFF_def,DRESTRICT_DEF,FAPPLY_FUPDATE_THM, add_args_def]) \\ Cases_on `∃n. op = FFI n` \\ full_simp_tac(srw_ss())[] THEN1 ( @@ -4315,6 +4511,9 @@ Proof >- (fs[state_rel_def] >> res_tac >> fs[] >> rfs[]) \\ Cases_on`x` \\ full_simp_tac(srw_ss())[] \\ Cases_on`x'` \\ full_simp_tac(srw_ss())[] + >~ [`FLOOKUP _ _ = SOME (ValueArray _)`] + >- (fs[state_rel_def] >> res_tac >> fs[] >> rfs[] >> rveq) + >~ [`FLOOKUP _ _ = SOME (Thunk _ _)`] >- (fs[state_rel_def] >> res_tac >> fs[] >> rfs[] >> rveq) \\ Cases_on`call_FFI p1.ffi (ExtCall n) l l''` \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] @@ -4355,11 +4554,15 @@ Proof \\ SIMP_TAC std_ss [INJ_DEF,FRANGE_DEF] \\ full_simp_tac(srw_ss())[FLOOKUP_DEF] \\ rveq \\ METIS_TAC []) \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] \\ Cases_on`x` >> full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] - \\ Q.PAT_X_ASSUM `LIST_REL pp xs' ws''` MP_TAC - \\ MATCH_MP_TAC listTheory.LIST_REL_mono - \\ REPEAT STRIP_TAC - \\ MATCH_MP_TAC v_rel_UPDATE_REF \\ full_simp_tac(srw_ss())[] - \\ full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC []) + >- ( + Q.PAT_X_ASSUM `LIST_REL pp xs' ws''` MP_TAC + \\ MATCH_MP_TAC listTheory.LIST_REL_mono + \\ REPEAT STRIP_TAC + \\ MATCH_MP_TAC v_rel_UPDATE_REF \\ full_simp_tac(srw_ss())[] + \\ full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC []) + >- ( + MATCH_MP_TAC v_rel_UPDATE_REF \\ full_simp_tac(srw_ss())[] + \\ full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC [])) \\ `m IN FRANGE f2` by (full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC []) \\ full_simp_tac(srw_ss())[SUBMAP_DEF,FDIFF_def,DRESTRICT_DEF,FAPPLY_FUPDATE_THM, add_args_def] \\ rveq \\ fs[]) @@ -4407,12 +4610,16 @@ Proof rw[FLOOKUP_UPDATE] \\ first_x_assum drule \\ rw[] \\ simp[] \\ rw[] >- ( fs[FLOOKUP_DEF] \\ METIS_TAC[LEAST_NOTIN_FDOM] ) \\ - Cases_on`x''` \\ fs[] \\ - match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) >> - ONCE_REWRITE_TAC[CONJ_COMM] >> - asm_exists_tac \\ fs[] \\ rw[] \\ - match_mp_tac v_rel_NEW_REF \\ - simp[LEAST_NOTIN_FDOM]) + Cases_on`x''` \\ fs[] + >- ( + match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) >> + ONCE_REWRITE_TAC[CONJ_COMM] >> + asm_exists_tac \\ fs[] \\ rw[] \\ + match_mp_tac v_rel_NEW_REF \\ + simp[LEAST_NOTIN_FDOM]) + >- ( + match_mp_tac v_rel_NEW_REF + \\ simp [LEAST_NOTIN_FDOM])) \\ simp[] \\ qmatch_goalsub_abbrev_tac`t2.refs |+ (ptr,_)` \\ `ptr ∉ FRANGE f2` @@ -4472,11 +4679,15 @@ Proof \\ res_tac \\ simp[] \\ rw[] \\ fs[] \\ rfs[IN_FRANGE_FLOOKUP] \\ rw[] \\ Cases_on`x` \\ fs[] - \\ match_mp_tac (MP_CANON(GEN_ALL LIST_REL_mono)) - \\ ONCE_REWRITE_TAC[CONJ_COMM] >> - asm_exists_tac \\ fs[] \\ rw[] \\ - match_mp_tac v_rel_NEW_REF - \\ fs[Abbr`ptr`,LEAST_NOTIN_FDOM] ) + >- ( + match_mp_tac (MP_CANON(GEN_ALL LIST_REL_mono)) + \\ ONCE_REWRITE_TAC[CONJ_COMM] >> + asm_exists_tac \\ fs[] \\ rw[] \\ + match_mp_tac v_rel_NEW_REF + \\ fs[Abbr`ptr`,LEAST_NOTIN_FDOM]) + >- ( + match_mp_tac v_rel_NEW_REF + \\ fs[Abbr`ptr`,LEAST_NOTIN_FDOM])) \\ Cases_on`∃fl. op = MemOp (CopyByte fl)` \\ fs[] >- ( fs[closSemTheory.do_app_def,bvlSemTheory.do_app_def,PULL_EXISTS] \\ Cases_on`fl` @@ -4514,6 +4725,81 @@ Proof \\ fs[FDIFF_def,DRESTRICT_DEF,SUBMAP_DEF,FAPPLY_FUPDATE_THM] \\ rw[DRESTRICT_DEF,FAPPLY_FUPDATE_THM] \\ rw[] \\ fs[IN_FRANGE_FLOOKUP] ) + \\ Cases_on `∃t. op = ThunkOp t` \\ gvs [] >- ( + Cases_on `t` \\ gvs [] + >- ( + gvs [closSemTheory.do_app_def, do_app_def, AllCaseEqs(), PULL_EXISTS] + \\ qabbrev_tac `pp = LEAST ptr. ptr NOTIN FDOM p1.refs` + \\ qabbrev_tac `qq = LEAST ptr. ptr NOTIN FDOM t2.refs` + \\ qexists `f2 |+ (pp,qq)` \\ gvs [] + \\ `¬(pp ∈ FDOM p1.refs)` by (unabbrev_all_tac \\ rw [LEAST_NOTIN_FDOM]) + \\ `¬(qq ∈ FDOM t2.refs)` by (unabbrev_all_tac \\ rw [LEAST_NOTIN_FDOM]) + \\ `¬(pp ∈ FDOM f2)` by gvs [state_rel_def] + \\ `¬(qq ∈ FRANGE f2)` by + (rpt strip_tac \\ gvs [state_rel_def, SUBSET_DEF] \\ res_tac) + \\ `FRANGE (f2 \\ pp) = FRANGE f2` by + (gvs [FRANGE_DEF, finite_mapTheory.DOMSUB_FAPPLY_THM, EXTENSION] + \\ metis_tac []) + \\ gvs [] + \\ fs [list_CASE_same] \\ rveq + \\ conj_tac >- (gvs [v_rel_cases, FLOOKUP_UPDATE]) + \\ conj_tac + >- ( + gvs [state_rel_def, FLOOKUP_UPDATE] + \\ rpt strip_tac + >- ( + qpat_x_assum `LIST_REL ppp qqq rrr` mp_tac + \\ match_mp_tac listTheory.LIST_REL_mono + \\ rpt strip_tac + \\ match_mp_tac OPTREL_v_rel_NEW_REF \\ gvs [] + \\ match_mp_tac OPTREL_v_rel_NEW_F \\ gvs []) + >- ( + qpat_x_assum `INJ ($' f2) (FDOM _) (FRANGE f2)` mp_tac + \\ rpt (qpat_x_assum `INJ xx yy zz` (K all_tac)) + \\ gvs [INJ_DEF,FAPPLY_FUPDATE_THM,FRANGE_DEF] + \\ rpt strip_tac \\ metis_tac []) + >- ( + ntac 2 (pop_assum mp_tac) \\ rw[] + \\ first_x_assum match_mp_tac \\ asm_exists_tac \\ rw[]) + \\ Cases_on `n = pp` \\ gvs [] + >- ( + gvs [] + \\ imp_res_tac evaluate_const + \\ match_mp_tac v_rel_NEW_REF \\ gvs [] + \\ match_mp_tac v_rel_NEW_F \\ gvs []) + \\ res_tac \\ gvs [] + \\ `qq ≠ m` by (strip_tac \\ gvs [FLOOKUP_DEF]) + \\ Cases_on `x` \\ gvs [] + >- ( + qpat_x_assum `LIST_REL (v_rel _ f2 t2.refs t2.code) l ws` mp_tac + \\ match_mp_tac LIST_REL_mono + \\ rpt strip_tac + \\ match_mp_tac v_rel_NEW_REF \\ gvs [] + \\ match_mp_tac v_rel_NEW_F \\ gvs []) + >- ( + match_mp_tac v_rel_NEW_REF \\ gvs [] + \\ match_mp_tac v_rel_NEW_F \\ gvs [])) + \\ conj_tac + >- (gvs [SUBMAP_DEF, FAPPLY_FUPDATE_THM] \\ metis_tac []) + \\ gvs [SUBMAP_DEF, FAPPLY_FUPDATE_THM, FDIFF_def, DRESTRICT_DEF] + \\ metis_tac []) + >- ( + gvs [closSemTheory.do_app_def, do_app_def, AllCaseEqs(), PULL_EXISTS] + \\ Cases_on `a` \\ gvs [] + \\ qpat_x_assum `v_rel _ _ _ _ (RefPtr _ _) y'` mp_tac + \\ reverse $ rw [Once v_rel_cases] + >- gvs [add_args_F] + >- rgs [Once cl_rel_cases] + \\ drule_all (GEN_ALL state_rel_refs_lookup) \\ rw [] \\ gvs [] + \\ goal_assum $ drule_at Any \\ gvs [] \\ rw [] + >- ( + drule (GEN_ALL state_rel_UPDATE_REF) + \\ rpt (disch_then drule) + \\ disch_then irule \\ gvs [] + \\ imp_res_tac evaluate_const \\ gvs []) + >- ( + `r2 ∈ (FRANGE f2)` by (rgs [TO_FLOOKUP] \\ rw [SF SFY_ss]) + \\ gvs [FDIFF_FUPDATE] \\ rw []))) \\ imp_res_tac closSemTheory.do_app_const \\ first_x_assum(mp_tac o INST_TYPE[beta|->gamma] o MATCH_MP (GEN_ALL(REWRITE_RULE[GSYM AND_IMP_INTRO]do_app))) @@ -4718,9 +5004,11 @@ Proof \\ REPEAT STRIP_TAC \\ RES_TAC \\ full_simp_tac(srw_ss())[FLOOKUP_UPDATE] \\ `m <> rr` by (REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[FLOOKUP_DEF]) \\ full_simp_tac(srw_ss())[] \\ Cases_on`x'''`>>full_simp_tac(srw_ss())[] - \\ Q.PAT_X_ASSUM `LIST_REL ppp xs ys'` MP_TAC - \\ MATCH_MP_TAC listTheory.LIST_REL_mono - \\ IMP_RES_TAC v_rel_NEW_REF \\ full_simp_tac(srw_ss())[]) + >- ( + Q.PAT_X_ASSUM `LIST_REL ppp xs ys'` MP_TAC + \\ MATCH_MP_TAC listTheory.LIST_REL_mono + \\ IMP_RES_TAC v_rel_NEW_REF \\ full_simp_tac(srw_ss())[]) + >- (IMP_RES_TAC v_rel_NEW_REF \\ full_simp_tac(srw_ss())[])) \\ TRY (simp[] \\ NO_TAC) \\ MATCH_MP_TAC env_rel_APPEND \\ reverse STRIP_TAC THEN1 diff --git a/compiler/backend/proofs/data_spaceProofScript.sml b/compiler/backend/proofs/data_spaceProofScript.sml index 57ffc24bc0..1ff8935e3a 100644 --- a/compiler/backend/proofs/data_spaceProofScript.sml +++ b/compiler/backend/proofs/data_spaceProofScript.sml @@ -1,7 +1,7 @@ (* Correctness proof for data_space *) -open preamble data_spaceTheory dataSemTheory dataPropsTheory; +open preamble dataLangTheory data_spaceTheory dataSemTheory dataPropsTheory; val _ = temp_delsimps ["NORMEQ_CONV"] @@ -33,8 +33,6 @@ Proof \\ rw [] \\ fs [] \\ res_tac \\ fs [] QED -val case_eq_thms = bvlPropsTheory.case_eq_thms; - Theorem do_stack_with_space: ∀op vs s z . do_stack op vs (s with space := z) = (do_stack op vs s) with space := z Proof @@ -77,7 +75,21 @@ Proof \\ fs[lookup_insert,state_component_equality] \\ METIS_TAC []) THEN1 (* Assign *) - (BasicProvers.TOP_CASE_TAC \\ fs[cut_state_opt_def] + (Cases_on `op = ThunkOp ForceThunk` >- ( + gvs [op_requires_names_def, op_space_reset_def, cut_state_opt_def, + cut_state_def, AllCaseEqs(), PULL_EXISTS] + \\ imp_res_tac locals_ok_cut_env \\ gvs [] + \\ ( + (qmatch_goalsub_abbrev_tac `locals_ok ss.locals _`) + ORELSE (qabbrev_tac `ss = s`) + \\ qexistsl [`ss.locals`, `ss.safe_for_space`, `ss.peak_heap_length`, + `ss.stack_max`] \\ gvs [Abbr `ss`, state_component_equality] + \\ gvs [cut_env_def] + \\ `locals_ok s.locals s.locals` by gvs [locals_ok_refl] + \\ gvs [locals_ok_def] \\ rw [] + \\ gvs [lookup_inter_alt])) + \\ gvs [] + \\ BasicProvers.TOP_CASE_TAC \\ fs[cut_state_opt_def] \\ BasicProvers.CASE_TAC \\ fs[] THEN1 (Cases_on `get_vars args s.locals` \\ fs[cut_state_opt_def] @@ -212,7 +224,8 @@ Proof \\ MAP_EVERY Q.EXISTS_TAC [`w'`,`safe'''`,`peak'''`,`smx'''`] \\ IF_CASES_TAC \\ fs []) THEN1 (* Assign *) - (fs[pMakeSpace_def,space_def] \\ reverse (Cases_on `o0`) + (Cases_on `o' = ThunkOp ForceThunk` >- cheat \\ gvs [] + \\ fs[pMakeSpace_def,space_def] \\ reverse (Cases_on `o0`) \\ fs[evaluate_def,cut_state_opt_def] THEN1 (fs[pMakeSpace_def,space_def,evaluate_def, diff --git a/compiler/backend/proofs/flat_patternProofScript.sml b/compiler/backend/proofs/flat_patternProofScript.sml index 59a6b01b1a..3fca38febe 100644 --- a/compiler/backend/proofs/flat_patternProofScript.sml +++ b/compiler/backend/proofs/flat_patternProofScript.sml @@ -1777,7 +1777,7 @@ Proof store_lookup_def] \\ rgs [Once v_rel_cases] \\ `∃a. EL n t2.refs = Thunk NotEvaluated a ∧ - v_rel f a` by ( + v_rel v a` by ( gvs [state_rel_def, LIST_REL_EL_EQN] \\ qpat_x_assum `∀n. n < LENGTH t2.refs ⇒ _` drule \\ rw [] \\ Cases_on `EL n t2.refs` \\ gvs []) \\ gvs [] @@ -1793,7 +1793,7 @@ Proof \\ gvs [state_rel_def, LIST_REL_EL_EQN, EL_LUPDATE] \\ rw [] >- ( - qpat_x_assum `v_rel v y` mp_tac + qpat_x_assum `v_rel v'' y` mp_tac \\ gvs [oneline dest_thunk_def, AllCaseEqs()] \\ rw [Once v_rel_cases] \\ gvs [store_lookup_def] @@ -1808,7 +1808,7 @@ Proof store_lookup_def] \\ rgs [Once v_rel_cases] \\ `∃a. EL n t2.refs = Thunk NotEvaluated a ∧ - v_rel f a` by ( + v_rel v a` by ( gvs [state_rel_def, LIST_REL_EL_EQN] \\ qpat_x_assum `∀n. n < LENGTH t2.refs ⇒ _` drule \\ rw [] \\ Cases_on `EL n t2.refs` \\ gvs []) \\ gvs [] diff --git a/compiler/backend/proofs/flat_to_closProofScript.sml b/compiler/backend/proofs/flat_to_closProofScript.sml index 12f5ae97d4..a2a0db5706 100644 --- a/compiler/backend/proofs/flat_to_closProofScript.sml +++ b/compiler/backend/proofs/flat_to_closProofScript.sml @@ -130,6 +130,15 @@ Proof \\ fs [flatSemTheory.list_to_v_def,list_to_v_def,v_rel_def] QED +Theorem lookup_refv: + state_rel s1 t1 /\ store_lookup i s1.refs = SOME (Refv v) ==> + ?w. FLOOKUP t1.refs i = SOME (ValueArray [w]) /\ v_rel v w +Proof + gvs [state_rel_def,store_rel_def] \\ rw [] + \\ gvs [store_lookup_def] + \\ first_x_assum (qspec_then `i` mp_tac) \\ gvs [] +QED + Theorem lookup_byte_array: state_rel s1 t1 /\ store_lookup i s1.refs = SOME (W8array bytes) ==> FLOOKUP t1.refs i = SOME (ByteArray bytes) @@ -1444,11 +1453,10 @@ Proof AllCaseEqs()] \\ gvs [Once v_rel_cases, store_thunk_def, AllCaseEqs(), PULL_EXISTS] \\ ( - gvs [state_rel_def, store_rel_def, FLOOKUP_UPDATE, EL_LUPDATE] \\ rw [] - \\ TRY ( - gvs [store_lookup_def] - \\ last_x_assum $ qspec_then `n` assume_tac \\ gvs [] - \\ NO_TAC) + TRY (drule_all lookup_refv \\ rw [] \\ gvs []) + \\ TRY (drule_all lookup_byte_array \\ rw [] \\ gvs []) + \\ TRY (drule_all lookup_array \\ rw [] \\ gvs []) + \\ gvs [state_rel_def, store_rel_def, FLOOKUP_UPDATE, EL_LUPDATE] \\ rw [] >- ( rename1 `FLOOKUP s2.refs idx = _` \\ last_x_assum $ qspec_then `idx` assume_tac \\ gvs []) diff --git a/compiler/backend/proofs/source_evalProofScript.sml b/compiler/backend/proofs/source_evalProofScript.sml index 495aa06019..8950244382 100644 --- a/compiler/backend/proofs/source_evalProofScript.sml +++ b/compiler/backend/proofs/source_evalProofScript.sml @@ -1083,7 +1083,7 @@ Proof gvs [oneline dest_thunk_def, AllCaseEqs(), oneline store_lookup_def] \\ gvs [s_rel_def, LIST_REL_EL_EQN] \\ `∃a. EL n refs'' = Thunk NotEvaluated a ∧ - v_rel orac_s'' f a` by ( + v_rel orac_s'' v a` by ( first_x_assum drule \\ rw [] \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs [] \\ simp [state_component_equality]) @@ -1091,7 +1091,7 @@ Proof gvs [oneline dest_thunk_def, AllCaseEqs(), oneline store_lookup_def] \\ `n < LENGTH t''.refs ∧ ∃a. EL n t''.refs = Thunk NotEvaluated a ∧ - v_rel (orac_s t''.eval_state) f a` by ( + v_rel (orac_s t''.eval_state) v a` by ( gvs [s_rel_def, LIST_REL_EL_EQN] \\ first_x_assum drule \\ rw [] \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs [] @@ -1110,8 +1110,8 @@ Proof \\ gvs [oneline store_assign_def] \\ rw [] >- ( gvs [oneline dest_thunk_def] - \\ qpat_x_assum `v_rel _ v y` mp_tac - \\ Cases_on `v` \\ Cases_on `y` \\ rw [Once v_rel_cases] + \\ qpat_x_assum `v_rel _ v'' y` mp_tac + \\ Cases_on `v''` \\ Cases_on `y` \\ rw [Once v_rel_cases] >- ( gvs [oneline store_v_same_type_def] \\ gvs [oneline store_lookup_def] @@ -1136,7 +1136,7 @@ Proof gvs [oneline dest_thunk_def, AllCaseEqs(), oneline store_lookup_def] \\ `n < LENGTH t''.refs ∧ ∃a. EL n t''.refs = Thunk NotEvaluated a ∧ - v_rel (orac_s t''.eval_state) f a` by ( + v_rel (orac_s t''.eval_state) v a` by ( gvs [s_rel_def, LIST_REL_EL_EQN] \\ first_x_assum drule \\ rw [] \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs [] diff --git a/compiler/backend/proofs/source_to_flatProofScript.sml b/compiler/backend/proofs/source_to_flatProofScript.sml index 7fd2bac187..ef4c4f4087 100644 --- a/compiler/backend/proofs/source_to_flatProofScript.sml +++ b/compiler/backend/proofs/source_to_flatProofScript.sml @@ -4326,7 +4326,7 @@ Proof `n + 1 < LENGTH s'_i1.refs` by (Cases_on `s'_i1.refs` >> gvs[]) >> gvs[] >> `∃v'. EL n (TL s'_i1.refs) = Thunk NotEvaluated v' ∧ - v_rel genv' f v'` by ( + v_rel genv' v v'` by ( first_x_assum drule >> gvs[] >> rw[Once sv_rel_cases]) >> simp[REWRITE_RULE [ADD1] EL, Once result_rel_cases] >> goal_assum drule >> rw[]) @@ -4342,7 +4342,7 @@ Proof `n + 1 < LENGTH s'_i1.refs` by (Cases_on `s'_i1.refs` >> gvs[]) >> gvs[] >> `∃v'. EL n (TL s'_i1.refs) = Thunk NotEvaluated v' ∧ - v_rel genv' f v'` by ( + v_rel genv' v v'` by ( first_x_assum drule >> gvs[] >> rw[Once sv_rel_cases]) >> simp[REWRITE_RULE [ADD1] EL, Once result_rel_cases, PULL_EXISTS] >> last_x_assum mp_tac >> @@ -4355,9 +4355,9 @@ Proof gvs[invariant_def, evaluateTheory.dec_clock_def, dec_clock_def] >> gvs[s_rel_cases] >> gvs[env_all_rel_cases] >> rw[] >> - qexistsl [`nsBind "f" f nsEmpty`, `<|c := nsEmpty; v := nsEmpty|>`] >> + qexistsl [`nsBind "f" v nsEmpty`, `<|c := nsEmpty; v := nsEmpty|>`] >> rw[evaluateTheory.sing_env_def] - >- (qexists `[("f",f)]` >> rw[]) + >- (qexists `[("f",v)]` >> rw[]) >- simp[Once v_rel_cases] >- ntac 2 (simp[Once v_rel_cases])) >> rw[] >> gvs[] >> @@ -4368,11 +4368,13 @@ Proof rw[Once result_rel_cases] >> gvs[oneline evaluateTheory.update_thunk_def, AllCaseEqs()] >> simp[update_thunk_def] >> - `dest_thunk [y] s'_i1'.refs = NONE` by ( - qpat_x_assum `v_rel _ v y` mp_tac >> - Cases_on `v` >> Cases_on `y` >> + `dest_thunk [y] s'_i1'.refs = NotThunk` by ( + qpat_x_assum `v_rel _ v'3' y` mp_tac >> + Cases_on `v'3'` >> Cases_on `y` >> rw[Once v_rel_cases, dest_thunk_def, Boolv_def] >> - gvs[evaluateTheory.dest_thunk_def, store_lookup_def] >> rw[] >> + gvs[evaluateTheory.dest_thunk_def, store_lookup_def] >> + reverse $ rw [] + >- (Cases_on `s'_i1'.refs` >> gvs []) >> `n' < LENGTH (TL s'_i1'.refs)` by (Cases_on `s'_i1'.refs` >> gvs[]) >> gvs[] >> first_x_assum drule >> simp[REWRITE_RULE [ADD1] EL] >> @@ -4414,7 +4416,7 @@ Proof `n + 1 < LENGTH s'_i1.refs` by (Cases_on `s'_i1.refs` >> gvs[]) >> gvs[] >> `∃v'. EL n (TL s'_i1.refs) = Thunk NotEvaluated v' ∧ - v_rel genv' f v'` by ( + v_rel genv' v v'` by ( first_x_assum drule >> gvs[] >> rw[Once sv_rel_cases]) >> simp[REWRITE_RULE [ADD1] EL, Once result_rel_cases, PULL_EXISTS] >> last_x_assum mp_tac >> @@ -4427,9 +4429,9 @@ Proof gvs[invariant_def, evaluateTheory.dec_clock_def, dec_clock_def] >> gvs[s_rel_cases] >> gvs[env_all_rel_cases] >> rw[] >> - qexistsl [`nsBind "f" f nsEmpty`, `<|c := nsEmpty; v := nsEmpty|>`] >> + qexistsl [`nsBind "f" v nsEmpty`, `<|c := nsEmpty; v := nsEmpty|>`] >> rw[evaluateTheory.sing_env_def] - >- (qexists `[("f",f)]` >> rw[]) + >- (qexists `[("f",v)]` >> rw[]) >- simp[Once v_rel_cases] >- ntac 2 (simp[Once v_rel_cases])) >> rw[] >> gvs[] >> diff --git a/compiler/backend/semantics/bviPropsScript.sml b/compiler/backend/semantics/bviPropsScript.sml index da4383870f..8dde8e29e8 100644 --- a/compiler/backend/semantics/bviPropsScript.sml +++ b/compiler/backend/semantics/bviPropsScript.sml @@ -128,7 +128,8 @@ val evaluate_LENGTH = Q.prove( HO_MATCH_MP_TAC evaluate_ind \\ REPEAT STRIP_TAC \\ FULL_SIMP_TAC (srw_ss()) [evaluate_def,case_elim_thms] \\ rw[] \\ fs[] - \\ every_case_tac \\ fs[]) + \\ every_case_tac \\ fs[] + \\ first_x_assum drule \\ rw []) |> SIMP_RULE std_ss []; Theorem evaluate_LENGTH = @@ -343,7 +344,9 @@ Proof \\ `(inc_clock n s).clock <> 0` by (EVAL_TAC \\ DECIDE_TAC) \\ full_simp_tac(srw_ss())[dec_clock_inv_clock1] \\ NO_TAC) THEN1 - (`?res5 s5. evaluate (xs,env,s) = (res5,s5)` by METIS_TAC [PAIR] + (Cases_on `op = ThunkOp ForceThunk` + >- gvs [AllCaseEqs(), dec_clock_def, inc_clock_def] + \\ `?res5 s5. evaluate (xs,env,s) = (res5,s5)` by METIS_TAC [PAIR] \\ full_simp_tac(srw_ss())[] \\ Cases_on `res5` \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] \\ TRY (Cases_on`e` \\ full_simp_tac(srw_ss())[] \\ NO_TAC) \\ MP_TAC (do_app_inv_clock |> Q.INST [`s`|->`s5`]) @@ -409,6 +412,15 @@ Proof qmatch_goalsub_rename_tac`a1 + (a2 + a3)` \\ qexists_tac`a3+a2+a1` \\ simp[GENLIST_APPEND,FOLDL_APPEND] \\ NO_TAC) + >- ( + gvs [AllCaseEqs(), FUN_EQ_THM] + >~ [`dest_thunk _ _ = BadRef`] >- (qexists `n` \\ gvs []) + >~ [`dest_thunk _ _ = NotThunk`] >- (qexists `n` \\ gvs []) + >~ [`dest_thunk _ _ = IsThunk Evaluated _`] >- (qexists `n` \\ gvs []) + >~ [`dest_thunk _ _ = IsThunk NotEvaluated _`] >- (qexists `n` \\ gvs []) + \\ qexists `n' + n` + \\ rewrite_tac [GENLIST_APPEND,FOLDL_APPEND,MAP_APPEND] + \\ gvs []) \\ Cases_on`op=Install` >- ( fs[do_app_def,do_install_def,case_eq_thms,bool_case_eq] @@ -472,6 +484,7 @@ Theorem do_app_with_code: do_app op vs (s with code := c) = Rval (r,s' with code := c) Proof rw [do_app_def,do_app_aux_def,case_eq_thms,pair_case_eq] + >~ [`ThunkOp`] >- gvs[bvlSemTheory.do_app_def, AllCaseEqs(), bvl_to_bvi_def] \\ fs[bvl_to_bvi_def,bvi_to_bvl_def,bvlSemTheory.do_app_def,case_eq_thms] \\ TRY (pairarg_tac \\ fs []) \\ rw[] \\ fs[] \\ rw[] \\ fs[case_eq_thms,pair_case_eq] \\ rw[] @@ -484,6 +497,7 @@ Theorem do_app_with_code_err: do_app op vs (s with code := c) = Rerr e Proof rw [do_app_def,do_app_aux_def,case_eq_thms,pair_case_eq] + >>~- ([`ThunkOp`], gvs [bvlSemTheory.do_app_def, AllCaseEqs()]) \\ fs[bvl_to_bvi_def,bvi_to_bvl_def,bvlSemTheory.do_app_def,case_eq_thms] \\ TRY (pairarg_tac \\ fs []) \\ rw[] \\ fs[] \\ rw[] \\ fs[case_eq_thms,pair_case_eq] \\ rw[] @@ -544,7 +558,9 @@ Proof srw_tac[][] >> full_simp_tac(srw_ss())[]) >- (Cases_on `evaluate ([x1],env,s)` >> full_simp_tac(srw_ss())[] >> Cases_on `q` >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[]) - >- (Cases_on `evaluate (xs,env,s)` >> full_simp_tac(srw_ss())[] >> + >- (Cases_on `op = ThunkOp ForceThunk` + >- gvs [AllCaseEqs(), dec_clock_def, inc_clock_def] >> + Cases_on `evaluate (xs,env,s)` >> full_simp_tac(srw_ss())[] >> Cases_on `q` >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >> srw_tac[][inc_clock_def] >> BasicProvers.EVERY_CASE_TAC >> diff --git a/compiler/backend/semantics/bviSemScript.sml b/compiler/backend/semantics/bviSemScript.sml index 6101527c94..2f4d8dc369 100644 --- a/compiler/backend/semantics/bviSemScript.sml +++ b/compiler/backend/semantics/bviSemScript.sml @@ -161,6 +161,51 @@ Definition do_app_def: | Rval (v,t) => Rval (v, bvl_to_bvi t s)) End +Datatype: + dest_thunk_ret + = BadRef + | NotThunk + | IsThunk thunk_mode v +End + +Definition dest_thunk_def: + dest_thunk [RefPtr _ ptr] refs = + (case FLOOKUP refs ptr of + | NONE => BadRef + | SOME (Thunk Evaluated v) => IsThunk Evaluated v + | SOME (Thunk NotEvaluated v) => IsThunk NotEvaluated v + | SOME _ => NotThunk) ∧ + dest_thunk vs refs = NotThunk +End + +Definition store_thunk_def: + store_thunk ptr v refs = + case FLOOKUP refs ptr of + | SOME (Thunk NotEvaluated _) => SOME (refs |+ (ptr,v)) + | _ => NONE +End + +Definition update_thunk_def: + update_thunk [RefPtr _ ptr] refs [v] = + (case dest_thunk [v] refs of + | NotThunk => store_thunk ptr (Thunk Evaluated v) refs + | _ => NONE) ∧ + update_thunk _ _ _ = NONE +End + +Definition AppUnit_def: + AppUnit = + If (Op (BlockOp Equal) + [Op (IntOp (Const 0)) []; + Op (MemOp El) [Op (IntOp (Const 1)) []; Var 0]]) + (Call 0 NONE + [Op (BlockOp (Cons 0)) []; Var 0; + Op (MemOp El) [Op (IntOp (Const 0)) []; Var 0]] + NONE) + (Call 0 (SOME num_stubs) [Op (BlockOp (Cons 0)) []; Var 0] NONE) +End + + (* The evaluation is defined as a clocked functional version of a conventional big-step operational semantics. *) @@ -205,10 +250,27 @@ Definition evaluate_def: | (Rval vs,s) => (Rerr(Rraise (HD vs)),s) | res => res) /\ (evaluate ([Op op xs],env,s) = - case evaluate (xs,env,s) of - | (Rval vs,s) => (case do_app op (REVERSE vs) s of - | Rerr e => (Rerr e,s) - | Rval (v,s) => (Rval [v],s)) + case fix_clock s (evaluate (xs,env,s)) of + | (Rval vs,s) => + if op = ThunkOp ForceThunk then + (case dest_thunk vs s.refs of + | BadRef => (Rerr (Rabort Rtype_error),s) + | NotThunk => (Rerr (Rabort Rtype_error),s) + | IsThunk Evaluated v => (Rval [v],s) + | IsThunk NotEvaluated f => + if s.clock = 0 then + (Rerr (Rabort Rtimeout_error),s) + else + case evaluate ([AppUnit],[f],(dec_clock 1 s)) of + | (Rval vs2,s) => + (case update_thunk vs s.refs vs2 of + | NONE => (Rerr (Rabort Rtype_error),s) + | SOME refs => (Rval vs2,s with refs := refs)) + | (Rerr e,s) => (Rerr e,s)) + else + (case do_app op (REVERSE vs) s of + | Rerr e => (Rerr e,s) + | Rval (v,s) => (Rval [v],s)) | res => res) /\ (evaluate ([Tick x],env,s) = if s.clock = 0 then (Rerr(Rabort Rtimeout_error),s) else diff --git a/compiler/backend/semantics/bvlPropsScript.sml b/compiler/backend/semantics/bvlPropsScript.sml index 7c1aa6656b..fa9bf672ca 100644 --- a/compiler/backend/semantics/bvlPropsScript.sml +++ b/compiler/backend/semantics/bvlPropsScript.sml @@ -82,8 +82,7 @@ Theorem do_app_Rval_swap: <| globals := x1.globals; refs := x1.refs; clock := x1.clock; ffi := x1.ffi |>) Proof - rw[do_app_cases_val] \\ rfs[SUBSET_DEF] \\ fs [] - \\ gvs [EVERY_MEM] \\ rw [] \\ res_tac \\ fs [] + rw[do_app_cases_val] \\ rfs[SUBSET_DEF] \\ fs [] \\ gvs [AllCaseEqs()] QED Theorem do_app_with_code: @@ -117,9 +116,7 @@ Theorem do_app_Rerr_swap: Proof Cases_on `op` \\ rw[do_app_cases_err] \\ rfs[SUBSET_DEF] \\ fs [] \\ TRY (strip_tac \\ res_tac \\ fs []) - \\ gvs [EXISTS_MEM] - \\ last_x_assum $ irule_at Any \\ fs [] - \\ strip_tac \\ res_tac \\ fs [] + \\ gvs [AllCaseEqs()] QED Theorem do_app_with_code_err_not_Install: @@ -130,8 +127,7 @@ Theorem do_app_with_code_err_not_Install: ; compile_oracle := co |>) = Rerr e Proof rw [Once do_app_cases_err] >> rw [do_app_def] >> fs [SUBSET_DEF] >> - fs [do_install_def,case_eq_thms,UNCURRY] >> - gvs [EVERY_MEM,EXISTS_MEM] + gvs [AllCaseEqs()] QED Theorem do_app_with_code_err: @@ -144,12 +140,14 @@ Proof rveq \\ fs [PULL_EXISTS] \\ CCONTR_TAC \\ fs [] THEN1 gvs [EVERY_MEM,EXISTS_MEM] - \\ rename1 `s.compile _ args = _` - \\ qpat_x_assum `args = _` (fn th => fs [GSYM th]) - \\ Cases_on `s.compile (FST (s.compile_oracle 0)) args` \\ fs [] - \\ PairCases_on `x` \\ fs [] - \\ Cases_on `v6` \\ fs [] - \\ rveq \\ fs [] \\ rfs [] + \\ TRY ( + rename1 `s.compile _ args = _` + \\ qpat_x_assum `args = _` (fn th => fs [GSYM th]) + \\ Cases_on `s.compile (FST (s.compile_oracle 0)) args` \\ fs [] + \\ PairCases_on `x` \\ fs [] + \\ Cases_on `v6` \\ fs [] + \\ rveq \\ fs [] \\ rfs []) + \\ gvs [AllCaseEqs()] QED Theorem initial_state_simp[simp]: @@ -336,17 +334,30 @@ Proof (qexists_tac `n+n'` \\ fs [shift_seq_def] \\ rewrite_tac [GENLIST_APPEND,FOLDL_APPEND,MAP_APPEND]) \\ metis_tac []) - THEN1 - (reverse (fs [case_eq_thms] \\ rw [] \\ fs []) - THEN1 metis_tac [] THEN1 metis_tac [] - \\ reverse (Cases_on `op = Install`) - THEN1 (imp_res_tac do_app_const \\ qexists_tac `n` \\ fs []) - \\ fs [do_app_def,do_install_def,case_eq_thms,UNCURRY] \\ rveq \\ fs [] - \\ qexists_tac `SUC n` - \\ fs [shift_seq_def,FUN_EQ_THM,ADD1] - \\ once_rewrite_tac [ADD_COMM] - \\ rewrite_tac [GENLIST_APPEND,MAP_APPEND,EVAL ``GENLIST f 1``] - \\ fs [FOLDL_APPEND] \\ rfs []) + THEN1 ( + fs [case_eq_thms] \\ reverse $ rw [] \\ gvs [dec_clock_def] + \\ TRY (metis_tac []) + >- ( + Cases_on `op` \\ gvs [do_app_def, AllCaseEqs()] + >~ [`do_install`] >- ( + gvs [do_install_def, AllCaseEqs()] + \\ pairarg_tac \\ gvs [AllCaseEqs(), shift_seq_def] + \\ qmatch_goalsub_rename_tac `nn + _` + \\ qexists `nn + 1` \\ gvs [] + \\ once_rewrite_tac [ADD_COMM] + \\ gvs [GENLIST_APPEND] + \\ simp [GSYM SNOC_APPEND, FOLDL_SNOC]) + \\ rpt (pairarg_tac \\ gvs []) + \\ metis_tac []) + \\ gvs [AllCaseEqs()] + >~ [`dest_thunk _ _ = BadRef`] >- (qexists `n` \\ gvs []) + >~ [`dest_thunk _ _ = NotThunk`] >- (qexists `n` \\ gvs []) + >~ [`dest_thunk _ _ = IsThunk Evaluated _`] >- (qexists `n` \\ gvs []) + >~ [`dest_thunk _ _ = IsThunk NotEvaluated _`] >- (qexists `n` \\ gvs []) + \\ qexists `n' + n` + \\ rewrite_tac [GENLIST_APPEND,FOLDL_APPEND,MAP_APPEND] + \\ fs [dec_clock_def,shift_seq_def,FUN_EQ_THM] + \\ simp_tac std_ss [Once ADD_COMM] \\ fs []) THEN1 (fs [case_eq_thms] \\ rw [] \\ fs [] THEN1 (qexists_tac `0` \\ fs [shift_seq_def,FUN_EQ_THM]) @@ -393,7 +404,7 @@ Theorem evaluate_MAP_Const: evaluate (MAP (K (Op (IntOp (Const i)) [])) (exps:'a list),env,t1) = (Rval (MAP (K (Number i)) exps),t1) Proof - Induct \\ full_simp_tac(srw_ss())[evaluate_def,evaluate_CONS,do_app_def] + Induct \\ full_simp_tac(srw_ss())[evaluate_def,Once evaluate_CONS,do_app_def] QED Theorem evaluate_Bool[simp]: @@ -492,7 +503,7 @@ Theorem do_app_change_clock: (do_app op args (s1 with clock := ck) = Rval (res,s2 with clock := ck)) Proof rw [do_app_cases_val,UNCURRY,do_install_def] - \\ every_case_tac \\ fs [] + \\ every_case_tac \\ fs [state_component_equality] QED Theorem do_app_change_clock_err: @@ -533,16 +544,11 @@ Proof >- (Cases_on `evaluate ([x1],env,s1)` >> full_simp_tac(srw_ss())[] >> Cases_on `q` >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >> Cases_on`e`>>full_simp_tac(srw_ss())[]>>srw_tac[][]>>full_simp_tac(srw_ss())[]) - >- (Cases_on `evaluate (xs,env,s)` >> full_simp_tac(srw_ss())[] >> - Cases_on `q` >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >> - srw_tac[][inc_clock_def] >> - BasicProvers.EVERY_CASE_TAC >> - full_simp_tac(srw_ss())[] >> - imp_res_tac do_app_const >> - imp_res_tac do_app_change_clock >> - imp_res_tac do_app_change_clock_err >> - full_simp_tac(srw_ss())[] >> - srw_tac[][]) + >- ( + gvs [AllCaseEqs(), inc_clock_def, dec_clock_def] >> + imp_res_tac do_app_const >> gvs [] >> + imp_res_tac do_app_change_clock >> gvs [] >> + imp_res_tac do_app_change_clock_err >> gvs []) >- (srw_tac[][] >> full_simp_tac(srw_ss())[inc_clock_def, dec_clock_def] >> srw_tac[][] >> @@ -646,6 +652,7 @@ Proof imp_res_tac do_app_io_events_mono >> TRY(fsrw_tac[ARITH_ss][] >>NO_TAC) >> full_simp_tac(srw_ss())[dec_clock_inc_clock] >> + TRY (rename1 `dest_thunk _ _ = _` >> gvs [dec_clock_def, inc_clock_def]) >> metis_tac[evaluate_io_events_mono,SND,IS_PREFIX_TRANS,Boolv_11,PAIR, inc_clock_ffi,dec_clock_ffi] QED @@ -760,6 +767,7 @@ Proof \\ BasicProvers.EVERY_CASE_TAC \\ full_simp_tac(srw_ss())[] \\ REV_FULL_SIMP_TAC std_ss [] \\ IMP_RES_TAC SUBSET_TRANS + \\ gvs [oneline update_thunk_def, AllCaseEqs(), store_thunk_def] \\ full_simp_tac(srw_ss())[dec_clock_def] \\ full_simp_tac(srw_ss())[] \\ IMP_RES_TAC do_app_refs_SUBSET \\ full_simp_tac(srw_ss())[SUBSET_DEF] QED diff --git a/compiler/backend/semantics/bvlSemScript.sml b/compiler/backend/semantics/bvlSemScript.sml index 0fe43dbad4..79b126bea2 100644 --- a/compiler/backend/semantics/bvlSemScript.sml +++ b/compiler/backend/semantics/bvlSemScript.sml @@ -18,6 +18,7 @@ Datatype: F = compare-by-pointer, mutable *) (* in closLang all are ByteArray F, ByteArray T introduced in BVL to implement ByteVector *) + | Thunk thunk_mode 'a End (* these parts are shared by bytecode and, if bytecode is to be supported, need @@ -440,6 +441,17 @@ Definition do_app_def: then Rval (Boolv (i < &n),s) else Error | _ => Error) | (MemOp ConfigGC,[Number _; Number _]) => (Rval (Unit, s)) + | (ThunkOp th_op, vs) => + (case (th_op,vs) of + | (AllocThunk m, [v]) => + (let ptr = (LEAST ptr. ~(ptr IN FDOM s.refs)) in + Rval (RefPtr F ptr, s with refs := s.refs |+ (ptr,Thunk m v))) + | (UpdateThunk m, [RefPtr _ ptr; v]) => + (case FLOOKUP s.refs ptr of + | SOME (Thunk NotEvaluated _) => + Rval (Unit, s with refs := s.refs |+ (ptr,Thunk m v)) + | _ => Error) + | _ => Error) | _ => Error End @@ -467,6 +479,51 @@ Definition find_code_def: | other => NONE) End +(* Functions for working with thunks *) + +Datatype: + dest_thunk_ret + = BadRef + | NotThunk + | IsThunk thunk_mode v +End + +Definition dest_thunk_def: + dest_thunk [RefPtr _ ptr] refs = + (case FLOOKUP refs ptr of + | NONE => BadRef + | SOME (Thunk Evaluated v) => IsThunk Evaluated v + | SOME (Thunk NotEvaluated v) => IsThunk NotEvaluated v + | SOME _ => NotThunk) ∧ + dest_thunk vs refs = NotThunk +End + +Definition store_thunk_def: + store_thunk ptr v refs = + case FLOOKUP refs ptr of + | SOME (Thunk NotEvaluated _) => SOME (refs |+ (ptr,v)) + | _ => NONE +End + +Definition update_thunk_def: + update_thunk [RefPtr _ ptr] refs [v] = + (case dest_thunk [v] refs of + | NotThunk => store_thunk ptr (Thunk Evaluated v) refs + | _ => NONE) ∧ + update_thunk _ _ _ = NONE +End + +Definition mk_unit_def: + mk_unit = bvl$Op (BlockOp (Cons 0)) [] +End + +Definition AppUnit_def: + AppUnit = + If (Op (BlockOp Equal) [mk_const 0; mk_el (Var 0) (mk_const 1)]) + (Call 0 NONE [mk_unit; Var 0; mk_el (Var 0) (mk_const 0)]) + (Call 0 (SOME 0) [mk_unit; Var 0]) +End + (* The evaluation is defined as a clocked functional version of a conventional big-step operational semantics. *) @@ -520,10 +577,27 @@ Definition evaluate_def: | (Rerr(Rraise v),s) => evaluate ([x2],v::env,s) | res => res) /\ (evaluate ([Op op xs],env,s) = - case evaluate (xs,env,s) of - | (Rval vs,s) => (case do_app op (REVERSE vs) s of - | Rerr err => (Rerr err,s) - | Rval (v,s) => (Rval [v],s)) + case fix_clock s (evaluate (xs,env,s)) of + | (Rval vs,s) => + if op = ThunkOp ForceThunk then + (case dest_thunk vs s.refs of + | BadRef => (Rerr (Rabort Rtype_error),s) + | NotThunk => (Rerr (Rabort Rtype_error),s) + | IsThunk Evaluated v => (Rval [v],s) + | IsThunk NotEvaluated f => + if s.clock = 0 then + (Rerr (Rabort Rtimeout_error),s) + else + case evaluate ([AppUnit],[f],(dec_clock 1 s)) of + | (Rval vs2,s) => + (case update_thunk vs s.refs vs2 of + | NONE => (Rerr (Rabort Rtype_error),s) + | SOME refs => (Rval vs2,s with refs := refs)) + | (Rerr e,s) => (Rerr e,s)) + else + (case do_app op (REVERSE vs) s of + | Rerr err => (Rerr err,s) + | Rval (v,s) => (Rval [v],s)) | res => res) /\ (evaluate ([Tick x],env,s) = if s.clock = 0 then (Rerr(Rabort Rtimeout_error),s) else evaluate ([x],env,dec_clock 1 s)) /\ diff --git a/compiler/backend/semantics/closSemScript.sml b/compiler/backend/semantics/closSemScript.sml index b77362d54e..043965953d 100644 --- a/compiler/backend/semantics/closSemScript.sml +++ b/compiler/backend/semantics/closSemScript.sml @@ -576,13 +576,21 @@ Proof \\ pairarg_tac \\ gvs[case_eq_thms,pair_case_eq,bool_case_eq] QED +Datatype: + dest_thunk_ret + = BadRef + | NotThunk + | IsThunk thunk_mode v +End + Definition dest_thunk_def: dest_thunk [RefPtr _ ptr] refs = (case FLOOKUP refs ptr of - | SOME (Thunk Evaluated v) => SOME (INL v) - | SOME (Thunk NotEvaluated v) => SOME (INR v) - | _ => NONE) ∧ - dest_thunk vs refs = NONE + | NONE => BadRef + | SOME (Thunk Evaluated v) => IsThunk Evaluated v + | SOME (Thunk NotEvaluated v) => IsThunk NotEvaluated v + | SOME _ => NotThunk) ∧ + dest_thunk vs refs = NotThunk End Definition store_thunk_def: @@ -594,10 +602,9 @@ End Definition update_thunk_def: update_thunk [RefPtr _ ptr] refs [v] = - (if dest_thunk [v] refs = NONE then - store_thunk ptr (Thunk Evaluated v) refs - else - NONE) ∧ + (case dest_thunk [v] refs of + | NotThunk => store_thunk ptr (Thunk Evaluated v) refs + | _ => NONE) ∧ update_thunk _ _ _ = NONE End @@ -647,9 +654,10 @@ Definition evaluate_def[nocompute]: | (Rerr err,s) => (Rerr err,s)) else if op = ThunkOp ForceThunk then (case dest_thunk vs s.refs of - | NONE => (Rerr (Rabort Rtype_error),s) - | SOME (INL v) => (Rval [v],s) - | SOME (INR f) => + | BadRef => (Rerr (Rabort Rtype_error),s) + | NotThunk => (Rerr (Rabort Rtype_error),s) + | IsThunk Evaluated v => (Rval [v],s) + | IsThunk NotEvaluated f => if s.clock = 0 then (Rerr (Rabort Rtimeout_error),s) else diff --git a/compiler/backend/semantics/dataPropsScript.sml b/compiler/backend/semantics/dataPropsScript.sml index ff95c55b9b..39e626179e 100644 --- a/compiler/backend/semantics/dataPropsScript.sml +++ b/compiler/backend/semantics/dataPropsScript.sml @@ -22,7 +22,9 @@ Definition approx_of_def: | NONE => 0 | SOME (ByteArray _ bs) => LENGTH bs DIV (arch_size lims DIV 8) + 2 | SOME (ValueArray vs) => - approx_of lims vs (delete r refs) + LENGTH vs + 1) /\ + approx_of lims vs (delete r refs) + LENGTH vs + 1 + | SOME (Thunk _ v) => + approx_of lims [v] (delete r refs) + 2) /\ (approx_of lims [Block ts tag []] refs = 0) /\ (approx_of lims [Block ts tag vs] refs = approx_of lims vs refs + LENGTH vs + 1) @@ -217,7 +219,8 @@ val do_app_with_stack = time Q.prove( ; stack_max := (do_stack op vs (s with stack := z)).stack_max ; peak_heap_length := do_app_peak op vs (s with stack := z) |>)) I (do_app op vs s)`, - Cases_on `do_app op vs (s with stack := z)` + cheat (* SLOW *) + (*Cases_on `do_app op vs (s with stack := z)` \\ cases_on_op_fs `op` \\ TRY (rename [‘EqualConst cc’] \\ Cases_on ‘cc’) \\ ntac 2 ( @@ -231,7 +234,7 @@ val do_app_with_stack = time Q.prove( \\ rveq \\ fs []) \\ fs [allowed_op_def] \\ rw [state_component_equality] \\ simp [Once CONJ_COMM] - \\ rw [EQ_IMP_THM] \\ fs[stack_consumed_def,allowed_op_def,PULL_EXISTS]); + \\ rw [EQ_IMP_THM] \\ fs[stack_consumed_def,allowed_op_def,PULL_EXISTS]*)); val do_app_with_stack_and_locals = time Q.prove( `do_app op vs (s with <|locals_size := lsz; stack := z|>) = @@ -241,7 +244,8 @@ val do_app_with_stack_and_locals = time Q.prove( ; stack_max := (do_stack op vs (s with <|locals_size := lsz; stack := z|>)).stack_max ; peak_heap_length := do_app_peak op vs (s with <|locals_size := lsz; stack := z|>) |>)) I (do_app op vs s)`, - Cases_on `do_app op vs (s with <|locals_size := lsz; stack := z|>)` + cheat (* SLOW *) + (*Cases_on `do_app op vs (s with <|locals_size := lsz; stack := z|>)` \\ cases_on_op_fs `op` \\ TRY (rename [‘EqualConst cc’] \\ Cases_on ‘cc’) \\ ntac 2 ( @@ -255,12 +259,13 @@ val do_app_with_stack_and_locals = time Q.prove( \\ rveq \\ fs []) \\ fs[allowed_op_def] \\ rw [state_component_equality] \\ simp [Once CONJ_COMM] - \\ rw[EQ_IMP_THM] \\ fs[stack_consumed_def,allowed_op_def]); + \\ rw[EQ_IMP_THM] \\ fs[stack_consumed_def,allowed_op_def]*)); Theorem do_app_aux_with_space: do_app_aux op vs (s with space := z) = map_result (λ(x,y). (x,y with space := z)) I (do_app_aux op vs s) Proof - Cases_on `do_app_aux op vs (s with space := z)` + cheat (* SLOW *) + (*Cases_on `do_app_aux op vs (s with space := z)` \\ cases_on_op_fs `op` \\ TRY (rename [‘EqualConst cc’] \\ Cases_on ‘cc’) \\ ntac 2 ( @@ -271,13 +276,14 @@ Proof semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq, pair_case_eq,consume_space_def,check_lim_def] \\ TRY (pairarg_tac \\ fs []) - \\ rveq \\ fs [] \\ rw []) + \\ rveq \\ fs [] \\ rw [])*) QED Theorem do_app_aux_with_locals: do_app_aux op vs (s with locals := z) = map_result (λ(x,y). (x,y with locals := z)) I (do_app_aux op vs s) Proof - Cases_on `do_app_aux op vs (s with locals := z)` + cheat (* SLOW *) + (*Cases_on `do_app_aux op vs (s with locals := z)` \\ cases_on_op_fs `op` \\ TRY (rename [‘EqualConst cc’] \\ Cases_on ‘cc’) \\ ntac 2 ( @@ -288,7 +294,7 @@ Proof semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq, pair_case_eq,consume_space_def,check_lim_def] \\ TRY (pairarg_tac \\ fs []) - \\ rveq \\ fs [] \\ rw []) + \\ rveq \\ fs [] \\ rw [])*) QED val do_app_with_locals = time Q.prove( @@ -298,7 +304,8 @@ val do_app_with_locals = time Q.prove( ; stack_max := (do_stack op vs (s with locals := z)).stack_max ; peak_heap_length := do_app_peak op vs (s with locals := z)|>)) I (do_app op vs s)`, - Cases_on `do_app op vs (s with locals := z)` + cheat (* SLOW *) + (*Cases_on `do_app op vs (s with locals := z)` \\ cases_on_op_fs `op` \\ TRY (rename [‘EqualConst cc’] \\ Cases_on ‘cc’) \\ ntac 2 ( @@ -312,7 +319,7 @@ val do_app_with_locals = time Q.prove( \\ rveq \\ fs []) \\ fs [allowed_op_def] \\ rw [state_component_equality] \\ simp [Once CONJ_COMM] - \\ rw[EQ_IMP_THM] \\ fs[stack_consumed_def,allowed_op_def]); + \\ rw[EQ_IMP_THM] \\ fs[stack_consumed_def,allowed_op_def]*)); Theorem do_app_aux_err: do_app_aux op vs s = Rerr e ⇒ (e = Rabort Rtype_error) @@ -432,8 +439,8 @@ Proof EVAL_TAC \\ rw [] QED -val do_app_swap_tac = - strip_tac +val do_app_swap_tac = cheat (* SLOW *); + (*strip_tac \\ cases_on_op_fs ‘op’ \\ TRY (rename [‘EqualConst cc’] \\ Cases_on ‘cc’) \\ rw [do_app_def,do_stack_def @@ -456,7 +463,7 @@ val do_app_swap_tac = \\ fs [data_spaceTheory.op_space_req_def,stack_consumed_def] \\ rfs [data_spaceTheory.op_space_req_def] \\ simp [Once CONJ_COMM] \\ NO_TAC) \\ - rpt(PURE_TOP_CASE_TAC \\ fs[] \\ rveq) \\ fs[state_component_equality,stack_consumed_def]; + rpt(PURE_TOP_CASE_TAC \\ fs[] \\ rveq) \\ fs[state_component_equality,stack_consumed_def];*) Theorem do_app_aux_safe_peak_swap: @@ -661,11 +668,20 @@ Proof >- basic_tac >- basic_tac (* Assign *) - >- (TOP_CASE_TAC \\ fs [evaluate_def] + >- ( + TOP_CASE_TAC \\ fs [evaluate_def] \\ full_cases >> full_fs \\ fs [] \\ rfs[] \\ rveq \\ fs [] \\ every_case_tac \\ fs [] \\ rveq \\ fs [] + \\ gvs [AllCaseEqs(), PULL_EXISTS] + >>~- ([`evaluate (AppUnit,_) = (SOME _,_)`, + `dest_thunk _ _ = IsThunk NotEvaluated _`], + TRY ( + first_x_assum $ qspecl_then [`T`, `smx`, `safe`, `peak`] assume_tac + \\ gvs [] \\ metis_tac []) + \\ first_x_assum $ qspecl_then [`F`, `smx`, `safe`, `peak`] assume_tac + \\ gvs [] \\ metis_tac []) \\ TRY (metis_tac [] \\ NO_TAC) \\ TRY (drule do_app_sm_safe_peak_swap \\ disch_then (qspecl_then [`smx`, `safe`, `peak`] assume_tac) @@ -894,7 +910,9 @@ Proof \\ every_case_tac \\ fs[state_component_equality,evaluate_safe_def,evaluate_peak_def]) (* Assign *) - >- (fs[evaluate_def] + >- ( + Cases_on `op = ThunkOp ForceThunk` >- cheat (* doesn't work *) + \\ fs[evaluate_def] \\ every_case_tac \\ fs[set_var_def,cut_state_opt_with_const,do_app_with_stack_and_locals] \\ imp_res_tac do_app_err >> fs[] >> rpt var_eq_tac @@ -1341,13 +1359,14 @@ Triviality evaluate_locals_LN_lemma: ((SND (evaluate (c,s))).locals = LN) \/ ?t. FST (evaluate (c,s)) = SOME (Rerr(Rraise t)) Proof - recInduct evaluate_ind \\ REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[evaluate_def] + cheat (* doesn't work *) + (*recInduct evaluate_ind \\ REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[evaluate_def] \\ every_case_tac \\ full_simp_tac(srw_ss())[call_env_def,flush_state_def,fromList_def] \\ imp_res_tac do_app_err >> full_simp_tac(srw_ss())[] >> rev_full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] \\ full_simp_tac(srw_ss())[LET_DEF] \\ SRW_TAC [] [] \\ full_simp_tac(srw_ss())[] \\ rpt(TOP_CASE_TAC >> fs[] >> rveq) \\ fs[markerTheory.Abbrev_def] - \\ rpt(TOP_CASE_TAC >> fs[] >> rveq) + \\ rpt(TOP_CASE_TAC >> fs[] >> rveq)*) QED Theorem evaluate_locals_LN: @@ -1434,7 +1453,17 @@ Proof \\ fs[lookup_insert,state_component_equality] \\ METIS_TAC []) (* Assign *) - >- (Cases_on `names_opt` \\ full_simp_tac(srw_ss())[] + >- (Cases_on `op = ThunkOp ForceThunk` \\ gvs [] + >- (gvs [op_requires_names_def, op_space_reset_def] + \\ Cases_on `names_opt` \\ gvs [] + \\ gvs [cut_state_opt_def] + \\ gvs [cut_state_def] + \\ Cases_on `cut_env x s.locals` \\ gvs [] + \\ imp_res_tac locals_ok_cut_env \\ gvs [] + \\ gvs [AllCaseEqs()] + \\ rw [state_component_equality, locals_ok_def] + \\ metis_tac []) + \\ Cases_on `names_opt` \\ full_simp_tac(srw_ss())[] \\ Cases_on `op_requires_names op` \\ fs [cut_state_opt_def] >- (Cases_on `get_vars args s.locals` \\ fs [] \\ fs [cut_state_opt_def] @@ -1719,12 +1748,20 @@ Proof >- (every_case_tac \\ fs[get_var_def,set_var_def] \\ srw_tac[][] >> fs[]) - >- (fs [do_app_aux_def,list_case_eq,option_case_eq,v_case_eq,cut_state_opt_def,cut_state_def - , bool_case_eq,ffiTheory.call_FFI_def,semanticPrimitivesTheory.result_case_eq - , with_fresh_ts_def,bvlSemTheory.ref_case_eq - , ffiTheory.ffi_result_case_eq,ffiTheory.oracle_result_case_eq - , semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq - , pair_case_eq,consume_space_def] + >- (Cases_on `op = ThunkOp ForceThunk` \\ gvs [] + >- ( + gvs [op_requires_names_def, op_space_reset_def] + \\ Cases_on `names_opt` \\ gvs [cut_state_opt_def] + \\ Cases_on `cut_state x s` \\ gvs [] + \\ gvs [cut_state_def] + \\ Cases_on `cut_env x s.locals` \\ gvs [] + \\ gvs [AllCaseEqs()]) + \\ fs [do_app_aux_def,list_case_eq,option_case_eq,v_case_eq,cut_state_opt_def,cut_state_def + , bool_case_eq,ffiTheory.call_FFI_def,semanticPrimitivesTheory.result_case_eq + , with_fresh_ts_def,bvlSemTheory.ref_case_eq + , ffiTheory.ffi_result_case_eq,ffiTheory.oracle_result_case_eq + , semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq + , pair_case_eq,consume_space_def] \\ rveq \\ fs [call_env_def,flush_state_def,do_app_with_clock,do_app_with_locals] \\ imp_res_tac do_app_const \\ fs [set_var_def,state_component_equality] \\ PairCases_on `y` \\ fs [] @@ -1913,6 +1950,22 @@ Proof \\ srw_tac[][] >> fs[set_var_with_const,flush_state_def] \\ metis_tac[evaluate_io_events_mono,SND,PAIR,IS_PREFIX_TRANS ,set_var_const,set_var_with_const,with_clock_ffi]) + \\ TRY ( + rename1 `op = ThunkOp ForceThunk` + \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs [] >- ( + gvs [op_requires_names_def, op_space_reset_def] + \\ Cases_on `names_opt` \\ gvs [cut_state_opt_def, cut_state_def] + \\ Cases_on `cut_env x s.locals` \\ gvs [] + \\ every_case_tac >> fs[cut_state_opt_with_const] >> rfs[] + \\ imp_res_tac evaluate_io_events_mono >> rfs[] + \\ fs [] >> imp_res_tac jump_exc_IMP >> rw[jump_exc_NONE,flush_state_def] + \\ metis_tac[evaluate_io_events_mono,IS_PREFIX_TRANS,SND,PAIR]) + \\ every_case_tac >> fs[cut_state_opt_with_const] >> rfs[] + \\ rveq >> fs[] >> rveq >> fs[] + \\ fs [do_app_with_clock] + \\ TRY (PairCases_on `y`) >> fs [] + \\ fs [] >> imp_res_tac jump_exc_IMP >> rw[jump_exc_NONE,flush_state_def] + \\ NO_TAC) \\ rpt (pairarg_tac >> fs[]) \\ every_case_tac >> fs[cut_state_opt_with_const] >> rfs[] \\ rveq >> fs[] >> rveq >> fs[] @@ -2040,6 +2093,15 @@ Theorem evaluate_safe_for_space_mono: evaluate (prog,s) = (res,s1) /\ s1.safe_for_space ==> s.safe_for_space Proof recInduct evaluate_ind \\ fs [evaluate_def] \\ rw[] + \\ TRY ( + rename1 `op = ThunkOp ForceThunk` + \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs [] >- ( + gvs [op_requires_names_def, op_space_reset_def] + \\ Cases_on `names_opt` \\ gvs [cut_state_opt_def, cut_state_def] + \\ gvs [AllCaseEqs()]) + \\ gvs [cut_state_opt_def, cut_state_def, AllCaseEqs()] + \\ gvs [set_var_def, flush_state_def] + \\ imp_res_tac do_app_safe_for_space_mono \\ gvs []) \\ fs [CaseEq"option",cut_state_opt_def,CaseEq"result",pair_case_eq, cut_state_def,jump_exc_def,CaseEq"stack",CaseEq"list"] \\ fs [] \\ rveq \\ fs [set_var_def,call_env_def,flush_state_def,dec_clock_def,add_space_def] @@ -2078,7 +2140,13 @@ Proof >- basic_tac (* Assign *) >- ( - fs [evaluate_def] + Cases_on `op = ThunkOp ForceThunk` >- ( + gvs [op_requires_names_def, op_space_reset_def, evaluate_def, + AllCaseEqs(), PULL_EXISTS] + \\ gvs [cut_state_opt_def, cut_state_def, AllCaseEqs()] + \\ TRY (last_x_assum $ qspec_then `limits'` assume_tac \\ gvs []) + \\ gvs [state_component_equality]) + \\ fs [evaluate_def] \\ full_cases >> full_fs \\ fs [] \\ rfs[] \\ rveq \\ fs [] @@ -2246,7 +2314,14 @@ Proof >- basics_tac >- basics_tac (* Assign *) - >- (fs [evaluate_def] + >- (Cases_on `op = ThunkOp ForceThunk` >- ( + gvs [op_requires_names_def, op_space_reset_def, evaluate_def, + cut_state_opt_def, cut_state_def, AllCaseEqs(), PULL_EXISTS] + \\ TRY ( + last_x_assum $ drule_then $ qspecl_then [`lsz`, `sfs`] assume_tac + \\ gvs []) + \\ gvs [state_component_equality]) + \\ fs [evaluate_def] \\ full_cases >> full_fs \\ fs [] \\ rfs[] \\ rveq \\ fs [] @@ -2483,8 +2558,11 @@ Proof >- ((* Move *) fs[evaluate_def,CaseEq "option",set_var_def] >> rveq >> rw[]) >- ((* Assign *) - fs[evaluate_def,CaseEq"bool",CaseEq"option",CaseEq"result",CaseEq"prod", - cut_state_opt_def,cut_state_def,set_var_def,get_vars_def] >> + Cases_on `op = ThunkOp ForceThunk` + >- gvs [op_requires_names_def, op_space_reset_def, evaluate_def, + cut_state_opt_def, cut_state_def, AllCaseEqs()] + \\ fs[evaluate_def,CaseEq"bool",CaseEq"option",CaseEq"result",CaseEq"prod", + cut_state_opt_def,cut_state_def,set_var_def,get_vars_def] >> rveq >> fs[flush_state_def] >> imp_res_tac do_app_stack_max >> fs[]) >- ((* Tick *) @@ -2658,6 +2736,16 @@ Proof fs[evaluate_def,CaseEq "option",set_var_def] >> rveq >> fs[get_var_def,cc_co_only_diff_def]) >- ((* Assign *) + Cases_on `op = ThunkOp ForceThunk` >- ( + gvs [op_requires_names_def, op_space_reset_def, evaluate_def, + cut_state_opt_def, cut_state_def, cut_env_def, + AllCaseEqs(), PULL_EXISTS] >> + TRY ( + last_x_assum + $ qspec_then `t with <|locals := insert 0 v LN; + clock := t.clock - 1|>` assume_tac >> + gvs []) >> + gvs [cc_co_only_diff_def]) >> fs[evaluate_def] >> IF_CASES_TAC >- (fs[] >> rveq >> fs[]) >> @@ -2820,6 +2908,10 @@ Proof >- ((* Move *) fs[evaluate_def,CaseEq "option",set_var_def] >> rveq >> rw[]) >- ((* Assign *) + Cases_on `op = ThunkOp ForceThunk` >- ( + fs [op_requires_names_def, op_space_reset_def, cut_state_opt_def, + cut_state_def, evaluate_def, AllCaseEqs()] >> + gvs []) >> fs[evaluate_def,CaseEq"bool",CaseEq"option",CaseEq"result",CaseEq"prod", cut_state_opt_def,cut_state_def,set_var_def,get_vars_def] >> rveq >> fs[flush_state_def] >> diff --git a/compiler/backend/semantics/dataSemScript.sml b/compiler/backend/semantics/dataSemScript.sml index 693129e7a6..de4638b16b 100644 --- a/compiler/backend/semantics/dataSemScript.sml +++ b/compiler/backend/semantics/dataSemScript.sml @@ -121,7 +121,9 @@ Definition size_of_def: | NONE => (0, refs, seen) | SOME (ByteArray _ bs) => (LENGTH bs DIV (arch_size lims DIV 8) + 2, delete r refs, seen) | SOME (ValueArray vs) => let (n,refs,seen) = size_of lims vs (delete r refs) seen in - (n + LENGTH vs + 1, refs, seen)) /\ + (n + LENGTH vs + 1, refs, seen) + | SOME (Thunk _ v) => let (n,refs,seen) = size_of lims [v] (delete r refs) seen in + (n + 2, refs, seen)) /\ (size_of lims [Block ts tag []]) refs seen = (0, refs, seen) /\ (size_of lims [Block ts tag vs] refs seen = if IS_SOME (sptree$lookup ts seen) then (0, refs, seen) else @@ -1184,6 +1186,42 @@ Definition install_sfs_def[simp]: install_sfs op ^s = s with safe_for_space := (op ≠ closLang$Install ∧ s.safe_for_space) End +Datatype: + dest_thunk_ret + = BadRef + | NotThunk + | IsThunk thunk_mode v +End + +Definition dest_thunk_def: + dest_thunk [RefPtr _ ptr] refs = + (case lookup ptr refs of + | NONE => BadRef + | SOME (Thunk Evaluated v) => IsThunk Evaluated v + | SOME (Thunk NotEvaluated v) => IsThunk NotEvaluated v + | SOME _ => NotThunk) ∧ + dest_thunk vs refs = NotThunk +End + +Definition store_thunk_def: + store_thunk ptr v refs = + case lookup ptr refs of + | SOME (Thunk NotEvaluated _) => SOME (insert ptr v refs) + | _ => NONE +End + +Definition update_thunk_def: + update_thunk [RefPtr _ ptr] refs [v] = + (case dest_thunk [v] refs of + | NotThunk => store_thunk ptr (Thunk Evaluated v) refs + | _ => NONE) ∧ + update_thunk _ _ _ = NONE +End + +Definition AppUnit_def: + AppUnit = ARB +End + Definition evaluate_def: (evaluate (Skip,^s) = (NONE,s)) /\ (evaluate (Move dest src,s) = @@ -1197,10 +1235,29 @@ Definition evaluate_def: | SOME s => (case get_vars args s.locals of | NONE => (SOME (Rerr(Rabort Rtype_error)),s) - | SOME xs => (case do_app op xs s of - | Rerr e => (SOME (Rerr e),flush_state T (install_sfs op s)) - | Rval (v,s) => - (NONE, set_var dest v (install_sfs op s))))) /\ + | SOME xs => + if op = ThunkOp ForceThunk then + (case dest_thunk xs s.refs of + | BadRef => (SOME (Rerr (Rabort Rtype_error)),s) + | NotThunk => (SOME (Rerr (Rabort Rtype_error)),s) + | IsThunk Evaluated v => (SOME (Rval v),s) + | IsThunk NotEvaluated f => + if s.clock = 0 then + (SOME (Rerr (Rabort Rtimeout_error)),s) + else + case evaluate ( + AppUnit,s with <| locals := (insert 0 f LN); + clock := (s.clock - 1) |>) of + | (SOME (Rval x),s) => + (case update_thunk xs s.refs [x] of + | NONE => (SOME (Rerr (Rabort Rtype_error)),s) + | SOME refs => (SOME (Rval x),s with refs := refs)) + | (err,s) => (err,s)) + else + (case do_app op xs s of + | Rerr e => (SOME (Rerr e),flush_state T (install_sfs op s)) + | Rval (v,s) => + (NONE, set_var dest v (install_sfs op s))))) /\ (evaluate (Tick,s) = if s.clock = 0 then (SOME (Rerr(Rabort Rtimeout_error)),flush_state T s) else (NONE,dec_clock s)) /\ @@ -1269,7 +1326,8 @@ Definition evaluate_def: | (NONE,s) => (SOME (Rerr(Rabort Rtype_error)),s) | res => res))))) Termination - WF_REL_TAC `(inv_image (measure I LEX measure prog_size) + cheat + (*WF_REL_TAC `(inv_image (measure I LEX measure prog_size) (\(xs,s). (s.clock,xs)))` \\ rpt strip_tac \\ simp[dec_clock_def] @@ -1277,7 +1335,7 @@ Termination \\ imp_res_tac (GSYM fix_clock_IMP) \\ FULL_SIMP_TAC (srw_ss()) [set_var_def,push_env_clock, call_env_def,LET_THM] >- fs [LESS_OR_EQ,dec_clock_def] - \\ decide_tac + \\ decide_tac*) End val evaluate_ind = theorem"evaluate_ind"; diff --git a/compiler/backend/semantics/flatSemScript.sml b/compiler/backend/semantics/flatSemScript.sml index f8f645c619..e874d4f271 100644 --- a/compiler/backend/semantics/flatSemScript.sml +++ b/compiler/backend/semantics/flatSemScript.sml @@ -686,21 +686,28 @@ Definition do_eval_def: | _ => NONE) End +Datatype: + dest_thunk_ret + = BadRef + | NotThunk + | IsThunk thunk_mode v +End + Definition dest_thunk_def: dest_thunk [Loc _ n] st = (case store_lookup n st of - | SOME (Thunk Evaluated v) => SOME (INL v) - | SOME (Thunk NotEvaluated v) => SOME (INR v) - | _ => NONE) ∧ - dest_thunk vs st = NONE + | NONE => BadRef + | SOME (Thunk Evaluated v) => IsThunk Evaluated v + | SOME (Thunk NotEvaluated v) => IsThunk NotEvaluated v + | SOME _ => NotThunk) ∧ + dest_thunk vs st = NotThunk End Definition update_thunk_def: update_thunk [Loc _ n] st [v] = - (if dest_thunk [v] st = NONE then - store_assign n (Thunk Evaluated v) st - else - NONE) ∧ + (case dest_thunk [v] st of + | NotThunk => store_assign n (Thunk Evaluated v) st + | _ => NONE) ∧ update_thunk _ st _ = NONE End @@ -774,9 +781,10 @@ Definition evaluate_def: | NONE => (s, Rerr (Rabort Rtype_error))) else if op = ThunkOp ForceThunk then (case dest_thunk vs s.refs of - | NONE => (s, Rerr (Rabort Rtype_error)) - | SOME (INL v) => (s, Rval [v]) - | SOME (INR f) => + | BadRef => (s, Rerr (Rabort Rtype_error)) + | NotThunk => (s, Rerr (Rabort Rtype_error)) + | IsThunk Evaluated v => (s, Rval [v]) + | IsThunk NotEvaluated f => if s.clock = 0 then (s, Rerr (Rabort Rtimeout_error)) else diff --git a/semantics/evaluateScript.sml b/semantics/evaluateScript.sml index 94514bf7cc..b132f6b971 100644 --- a/semantics/evaluateScript.sml +++ b/semantics/evaluateScript.sml @@ -55,21 +55,36 @@ Definition do_real_check_def: | _ => SOME r)) End +(* With `dest_thunk` we check 3 things: + - The values contain exactly one reference + - The reference is valid + - The reference points to a thunk + We distinguish between `BadRef` and `NotThunk` instead of returning an option + with `NONE` for both, because we want `update_thunk` to succeed when + `dest_thunk` fails but only when the reference actually exists and points to + something other than a thunk. *) +Datatype: + dest_thunk_ret + = BadRef + | NotThunk + | IsThunk thunk_mode v +End + Definition dest_thunk_def: dest_thunk [Loc _ n] st = (case store_lookup n st of - | SOME (Thunk Evaluated v) => SOME (INL v) - | SOME (Thunk NotEvaluated v) => SOME (INR v) - | _ => NONE) ∧ - dest_thunk vs st = NONE + | NONE => BadRef + | SOME (Thunk Evaluated v) => IsThunk Evaluated v + | SOME (Thunk NotEvaluated v) => IsThunk NotEvaluated v + | SOME _ => NotThunk) ∧ + dest_thunk vs st = NotThunk End Definition update_thunk_def: update_thunk [Loc _ n] st [v] = - (if dest_thunk [v] st = NONE then - store_assign n (Thunk Evaluated v) st - else - NONE) ∧ + (case dest_thunk [v] st of + | NotThunk => store_assign n (Thunk Evaluated v) st + | _ => NONE) ∧ update_thunk _ st _ = NONE End @@ -141,9 +156,10 @@ Definition evaluate_def[nocompute]: ) | Force => (case dest_thunk vs st'.refs of - | NONE => (st', Rerr (Rabort Rtype_error)) - | SOME (INL v) => (st', Rval [v]) - | SOME (INR f) => + | BadRef => (st', Rerr (Rabort Rtype_error)) + | NotThunk => (st', Rerr (Rabort Rtype_error)) + | IsThunk Evaluated v => (st', Rval [v]) + | IsThunk NotEvaluated f => if st'.clock = 0 then (st', Rerr (Rabort Rtimeout_error)) else diff --git a/semantics/proofs/evaluatePropsScript.sml b/semantics/proofs/evaluatePropsScript.sml index 4b11117dc5..0cdb162711 100644 --- a/semantics/proofs/evaluatePropsScript.sml +++ b/semantics/proofs/evaluatePropsScript.sml @@ -452,12 +452,9 @@ Proof >- ( gvs [AllCaseEqs()] \\ step_tac - \\ fs[is_clock_io_mono_def, dec_clock_def] - \\ Cases_on `a` \\ gvs[update_thunk_def] - \\ Cases_on `h` \\ gvs[update_thunk_def] - \\ Cases_on `t` \\ gvs[update_thunk_def] - \\ Cases_on `a'` \\ gvs[update_thunk_def] - \\ Cases_on `t` \\ gvs[update_thunk_def, store_assign_def]) + \\ fs [is_clock_io_mono_def, dec_clock_def] + \\ gvs [oneline update_thunk_def, oneline dest_thunk_def, store_assign_def, + AllCaseEqs()]) >- (assume_tac (SIMP_RULE std_ss [] is_clock_io_mono_do_app_simple) \\ fs[]) >- (assume_tac (SIMP_RULE std_ss [] is_clock_io_mono_do_app_icing) \\ gs[]) \\ assume_tac (SIMP_RULE std_ss [] is_clock_io_mono_do_app_real) \\ fs[]) From de4145eb722b518720a588b6dc8901ac7978b2c4 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Sat, 17 May 2025 11:32:58 +0300 Subject: [PATCH 018/112] Progress on bvi_to_data --- .../backend/proofs/bvi_to_dataProofScript.sml | 77 ++++++++++- .../backend/proofs/data_liveProofScript.sml | 68 +++++++++- .../backend/proofs/data_spaceProofScript.sml | 22 ++- .../backend/semantics/dataPropsScript.sml | 127 ++++++++++++------ compiler/backend/semantics/dataSemScript.sml | 19 ++- 5 files changed, 261 insertions(+), 52 deletions(-) diff --git a/compiler/backend/proofs/bvi_to_dataProofScript.sml b/compiler/backend/proofs/bvi_to_dataProofScript.sml index b8116d0d9b..560456226c 100644 --- a/compiler/backend/proofs/bvi_to_dataProofScript.sml +++ b/compiler/backend/proofs/bvi_to_dataProofScript.sml @@ -71,6 +71,7 @@ QED Definition data_to_bvi_ref_def: data_to_bvi_ref (ValueArray l) = ValueArray (MAP data_to_bvi_v l) ∧ data_to_bvi_ref (ByteArray b bl) = ByteArray b bl +∧ data_to_bvi_ref (Thunk m v) = Thunk m (data_to_bvi_v v) End (* State relation *) @@ -361,13 +362,17 @@ val [ data_to_bvi_eq_Number, data_to_bvi_eq_Word64 Theorem data_to_bvi_ref_eq: (∀v fl ds. data_to_bvi_ref v = ByteArray fl ds ⇒ v = ByteArray fl ds) ∧ (∀v l. data_to_bvi_ref v = ValueArray l - ⇒ ∃l'. v = ValueArray l' ∧ l = MAP data_to_bvi_v l') + ⇒ ∃l'. v = ValueArray l' ∧ l = MAP data_to_bvi_v l') ∧ + (∀v m w. data_to_bvi_ref v = Thunk m w + ⇒ ∃w'. v = Thunk m w' ∧ w = data_to_bvi_v w') Proof rw [] \\ Cases_on `v` \\ fs [data_to_bvi_ref_def] \\ METIS_TAC [] QED -val [data_to_bvi_eq_ByteArray, data_to_bvi_eq_ValueArray] = - zip ["data_to_bvi_eq_ByteArray", "data_to_bvi_eq_ValueArray"] +val [data_to_bvi_eq_ByteArray, data_to_bvi_eq_ValueArray, + data_to_bvi_eq_Thunk] = + zip ["data_to_bvi_eq_ByteArray", "data_to_bvi_eq_ValueArray", + "data_to_bvi_eq_Thunk"] (CONJUNCTS data_to_bvi_ref_eq) |> map save_thm; (* Construction of the pre-image of `data_to_bvi_result` *) @@ -480,6 +485,7 @@ fun cases_on_op q = Cases_on q >| Theorem data_to_bvi_do_app: ∀op t r z res s1. op ≠ Install ∧ op ≠ IntOp Greater ∧ op ≠ IntOp GreaterEq ∧ (∀b. op ≠ MemOp (CopyByte b)) ∧ + op ≠ ThunkOp ForceThunk ∧ state_rel r t ∧ do_app op (MAP data_to_bvi_v z) r = Rval (res,s1) ⇒ ∃s2 pres. @@ -614,6 +620,14 @@ Proof >- (rename1 `UpdateByte` \\ Cases_on `z` \\ fs [data_to_bvi_ref_def,data_to_bvi_v_def] \\ rfs [data_to_bvi_v_def,Unit_def,bvlSemTheory.Unit_def] \\ rw [data_to_bvi_ref_def] \\ rfs [refs_rel_LEAST_eq,lookup_map,lookup_insert]) + >~ [`ThunkOp (AllocThunk t)`] + >- (rw [data_to_bvi_ref_def] + \\ gvs [refs_rel_LEAST_eq, lookup_map, map_replicate]) + >~ [`ThunkOp (UpdateThunk t)`] + >- (Cases_on `z` \\ gvs [data_to_bvi_ref_def, data_to_bvi_v_def] + \\ gvs [data_to_bvi_v_def, Unit_def, bvlSemTheory.Unit_def] + \\ rw [data_to_bvi_ref_def] + \\ gvs [refs_rel_LEAST_eq, lookup_map, lookup_insert, LUPDATE_MAP]) \\ (MAP_FIRST rename1 [`BoundsCheckArray`, `BoundsCheckByte`] \\ Cases_on `z` \\ fs [data_to_bvi_ref_def,data_to_bvi_v_def] \\ rfs [data_to_bvi_v_def,Unit_def,bvlSemTheory.Unit_def @@ -976,8 +990,61 @@ Proof \\ IMP_RES_TAC get_vars_inter \\ IMP_RES_TAC get_vars_reverse \\ rveq \\ fs []) + \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs [] >- ( + gvs [iAssign_def, dataLangTheory.op_requires_names_def, + dataLangTheory.op_space_reset_def] + \\ Cases_on `tail = F` \\ gvs [] + >- ( + gvs [evaluate_def, cut_state_opt_def, cut_state_def, cut_env_def] + \\ gvs [oneline bviSemTheory.dest_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ Cases_on `x0` \\ gvs [data_to_bvi_v_def] + >- ( + `∃v. lookup n' (map data_to_bvi_ref t2.refs) = + SOME (Thunk Evaluated v)`by gvs [state_rel_def] + \\ gvs [lookup_map] + \\ Cases_on `z` + \\ gvs [data_to_bvi_ref_def, dest_thunk_def, set_var_def] \\ rw [] + >- gvs [state_rel_def] + >- (unabbrev_all_tac \\ gvs [lookup_insert, lookup_inter]) + >- cheat + >- ( + unabbrev_all_tac + \\ gvs [lookup_insert, AllCaseEqs(), lookup_inter] + \\ first_x_assum drule \\ rw []) + >- ( + unabbrev_all_tac + \\ gvs [lookup_insert] \\ rw [] + >- gvs [state_rel_def] + \\ gvs [lookup_inter, AllCaseEqs(), lookup_list_to_num_set] + \\ Cases_on `MEM k live` \\ gvs []) + >- gvs [jump_exc_def] + >- gvs [var_corr_def, get_var_def, get_vars_def, lookup_map, + state_rel_def, data_to_bvi_ref_def]) + >- ( + `∃v. lookup n' (map data_to_bvi_ref t2.refs) = + SOME (Thunk NotEvaluated v)`by gvs [state_rel_def] + \\ gvs [lookup_map] + \\ Cases_on `z` + \\ gvs [data_to_bvi_ref_def, dest_thunk_def, set_var_def] \\ rw [] + \\ `r.clock = t2.clock` by gvs [state_rel_def] + \\ gvs [flush_state_def, data_to_bvi_result_def, state_rel_def]) + >- ( + `∃v. lookup n' (map data_to_bvi_ref t2.refs) = + SOME (Thunk NotEvaluated v)`by gvs [state_rel_def] + \\ gvs [lookup_map] + \\ Cases_on `z` + \\ gvs [data_to_bvi_ref_def, dest_thunk_def, set_var_def] \\ rw [] + \\ `r.clock = t2.clock` by gvs [state_rel_def] \\ gvs [PULL_EXISTS] + \\ `state_rel (dec_clock 1 r) (dec_clock t2)` + by gvs [bviSemTheory.dec_clock_def, dec_clock_def, state_rel_def] + \\ last_x_assum $ drule_at (Pat `state_rel _ _`) \\ gvs [] + \\ disch_then $ qspecl_then [`n`, `[n']`, `F`, `live`] mp_tac + \\ impl_tac >- cheat \\ rw [] + \\ cheat) + >- cheat)) \\ reverse(Cases_on `do_app op (REVERSE a) r`) \\ full_simp_tac(srw_ss())[] >- ( - imp_res_tac bviPropsTheory.do_app_err >> full_simp_tac(srw_ss())[] >> + cheat + (*imp_res_tac bviPropsTheory.do_app_err >> full_simp_tac(srw_ss())[] >> rveq >> IF_CASES_TAC >> fs[dataSemTheory.evaluate_def,iAssign_def,dataLangTheory.op_requires_names_def, cut_state_opt_def,cut_state_def,cut_env_def] >> @@ -986,7 +1053,7 @@ Proof rpt(PURE_CASE_TAC >> fs[data_to_bvi_v_def,GSYM MAP_REVERSE] >> rveq) >> fs[state_rel_def] >> rfs[] >> fs [data_to_bvi_result_def] >> - fs[call_env_def,flush_state_def,data_to_bvi_ref_def,lookup_map]) + fs[call_env_def,flush_state_def,data_to_bvi_ref_def,lookup_map]*)) \\ PairCases_on `a'` \\ full_simp_tac(srw_ss())[] \\ REV_FULL_SIMP_TAC std_ss [] \\ rpt var_eq_tac >> full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[LET_DEF,evaluate_def,iAssign_def] diff --git a/compiler/backend/proofs/data_liveProofScript.sml b/compiler/backend/proofs/data_liveProofScript.sml index 7bc0ace737..276d00b757 100644 --- a/compiler/backend/proofs/data_liveProofScript.sml +++ b/compiler/backend/proofs/data_liveProofScript.sml @@ -73,6 +73,8 @@ Proof \\ fs [state_rel_def,consume_space_def,case_eq_thms,do_install_def,UNCURRY] \\ ASM_SIMP_TAC (srw_ss()) [dataSemTheory.state_component_equality] \\ SRW_TAC [] [] \\ fs[] + \\ gvs [AllCaseEqs()] + \\ ASM_SIMP_TAC (srw_ss()) [dataSemTheory.state_component_equality] QED Triviality state_rel_IMP_do_app: @@ -112,6 +114,8 @@ Proof \\ fs [state_rel_def,consume_space_def,case_eq_thms,do_install_def,UNCURRY] \\ ASM_SIMP_TAC (srw_ss()) [dataSemTheory.state_component_equality] \\ SRW_TAC [] [] \\ fs[] + \\ gvs [AllCaseEqs()] + \\ ASM_SIMP_TAC (srw_ss()) [dataSemTheory.state_component_equality] QED Triviality state_rel_IMP_do_app_err: @@ -188,7 +192,69 @@ Proof \\ Cases_on `lookup src t1.locals` \\ fs [set_var_def,lookup_insert]) THEN1 (* Assign *) - (Cases_on `names_opt` THEN1 + (Cases_on `op = ThunkOp ForceThunk` + >- (gvs [] + \\ Cases_on `names_opt` \\ gvs [] + >- (qpat_x_assum `_ = compile (Assign _ _ _ _) _` mp_tac + \\ rw [compile_def, is_pure_def] + \\ gvs [evaluate_def, dataLangTheory.op_requires_names_def, + dataLangTheory.op_space_reset_def]) + \\ qpat_x_assum `_ = compile (Assign _ _ _ _) _` mp_tac + \\ rw [compile_def] + \\ gvs [evaluate_def, dataLangTheory.op_requires_names_def, + dataLangTheory.op_space_reset_def, cut_state_opt_def, + cut_state_def, cut_env_def] + \\ `s.refs = t1.refs` by gvs [state_rel_def] \\ gvs [] + \\ Cases_on `domain x ⊆ domain s.locals` \\ gvs [] + \\ `domain x ∩ domain (list_insert args (delete dest l2)) ⊆ + domain t1.locals` by + (gvs [domain_inter, domain_list_insert, SUBSET_DEF, state_rel_def] + \\ gvs [domain_lookup] + \\ gvs [PULL_EXISTS, oneTheory.one] \\ metis_tac []) + \\ gvs [] + \\ Cases_on `get_vars args (inter s.locals x)` \\ gvs [] + \\ `get_vars + args + (inter t1.locals (inter x (list_insert args (delete dest l2)))) = + SOME x'` by + (qpat_x_assum `xx = SOME vs` (fn th => once_rewrite_tac [GSYM th]) + \\ match_mp_tac EVERY_get_vars + \\ gvs [EVERY_MEM, lookup_inter_alt, domain_inter, + domain_list_insert] + \\ rw [] \\ gvs [state_rel_def] + \\ first_x_assum (match_mp_tac o GSYM) + \\ gvs [domain_inter, domain_list_insert]) \\ gvs [] + \\ Cases_on `dest_thunk x' t1.refs` \\ gvs [] + \\ Cases_on `t` \\ gvs [] + >- (gvs [state_rel_def, set_var_def, lookup_insert] + \\ rpt strip_tac \\ rw [call_env_def, flush_state_def] + \\ gvs [domain_inter, domain_list_insert, domain_delete] + \\ gvs [lookup_inter_alt, domain_inter, domain_list_insert, + domain_delete]) + \\ `s.clock = t1.clock` by gvs [state_rel_def] \\ gvs [] + \\ Cases_on `t1.clock = 0` \\ gvs [] + >- gvs [state_rel_def, flush_state_def] + \\ Cases_on `evaluate (AppUnit, s with <|locals := insert 0 v LN; + clock := t1.clock − 1|>)` + \\ gvs [] + \\ qmatch_asmsub_abbrev_tac `state_rel s t1 xx` + \\ `state_rel + (s with <|locals := insert 0 v LN; clock := t1.clock - 1|>) + (t1 with <|locals := insert 0 v LN; clock := t1.clock - 1|>) xx` + by gvs [state_rel_def] \\ gvs [] + \\ last_x_assum $ drule_then $ qspec_then `xx` assume_tac \\ gvs [] + \\ `(AppUnit,xx) = compile AppUnit xx` by cheat \\ gvs [] + \\ unabbrev_all_tac \\ gvs [] + \\ first_x_assum drule \\ rw [] + \\ Cases_on `q = SOME (Rerr (Rabort Rtype_error))` \\ gvs [] + \\ qpat_x_assum `_ ⇒ _` mp_tac + \\ impl_tac + >- (rw [] \\ gvs [jump_exc_def, AllCaseEqs(), state_rel_def]) + \\ rw [] \\ gvs [] + \\ gvs [AllCaseEqs(), PULL_EXISTS] + \\ first_x_assum (irule_at Any o GSYM) \\ gvs [PULL_EXISTS] + \\ cheat) + \\ Cases_on `names_opt` THEN1 (fs [compile_def] \\ Cases_on `lookup dest l2 = NONE ∧ is_pure op` \\ fs [] THEN1 diff --git a/compiler/backend/proofs/data_spaceProofScript.sml b/compiler/backend/proofs/data_spaceProofScript.sml index 1ff8935e3a..31b69ceeb7 100644 --- a/compiler/backend/proofs/data_spaceProofScript.sml +++ b/compiler/backend/proofs/data_spaceProofScript.sml @@ -224,7 +224,22 @@ Proof \\ MAP_EVERY Q.EXISTS_TAC [`w'`,`safe'''`,`peak'''`,`smx'''`] \\ IF_CASES_TAC \\ fs []) THEN1 (* Assign *) - (Cases_on `o' = ThunkOp ForceThunk` >- cheat \\ gvs [] + (Cases_on `o' = ThunkOp ForceThunk` + >- (gvs[] + \\ Cases_on `o0` \\ gvs [] + >- gvs [evaluate_def, op_requires_names_def, op_space_reset_def] + \\ gvs [space_def, pMakeSpace_def] + \\ simp [Once evaluate_def] + \\ pairarg_tac \\ gvs [] + \\ Cases_on `q = SOME (Rerr (Rabort Rtype_error))` \\ gvs [] + \\ first_x_assum drule \\ strip_tac \\ gvs [] + \\ reverse $ Cases_on `q = NONE` \\ gvs [] + >- metis_tac [] + \\ last_x_assum drule \\ strip_tac \\ gvs [] + \\ Cases_on `res = NONE` \\ gvs [] + \\ drule_then (qspecl_then [`smx`, `safe`, `peak`] assume_tac) + evaluate_smx_safe_peak_swap \\ gvs [] + \\ metis_tac []) \\ gvs [] \\ fs[pMakeSpace_def,space_def] \\ reverse (Cases_on `o0`) \\ fs[evaluate_def,cut_state_opt_def] THEN1 @@ -302,7 +317,8 @@ Proof domain_list_insert] \\ NO_TAC) \\ fs[do_app_def,do_space_alt] \\ IF_CASES_TAC - >- (fs[do_install_def,case_eq_thms] + >- (cheat (* broke for no reason + fs[do_install_def,case_eq_thms] \\ pairarg_tac \\ fs[] \\ pairarg_tac \\ fs[] \\ fs[case_eq_thms] \\ rveq @@ -335,7 +351,7 @@ Proof \\ MAP_EVERY qexists_tac [`safe''`,`peak''`,`smx`] \\ fs[] \\ Cases_on`res` \\ fs[] - \\ fs[locals_ok_def]) + \\ fs[locals_ok_def]*)) \\ IF_CASES_TAC THEN1 fs [] \\ REV_FULL_SIMP_TAC std_ss [] \\ fs[consume_space_def,flush_state_def] diff --git a/compiler/backend/semantics/dataPropsScript.sml b/compiler/backend/semantics/dataPropsScript.sml index 39e626179e..ad4de2fe9f 100644 --- a/compiler/backend/semantics/dataPropsScript.sml +++ b/compiler/backend/semantics/dataPropsScript.sml @@ -210,7 +210,8 @@ fun cases_on_op_fs q = Cases_on q \\ fs [] >>> SELECT_LT_THEN (Q.RENAME_TAC [‘WordOp w_’]) (Cases_on `w_`) >>> SELECT_LT_THEN (Q.RENAME_TAC [‘BlockOp b_’]) (Cases_on `b_`) >>> SELECT_LT_THEN (Q.RENAME_TAC [‘GlobOp g_’]) (Cases_on `g_`) - >>> SELECT_LT_THEN (Q.RENAME_TAC [‘MemOp m_’]) (Cases_on `m_`); + >>> SELECT_LT_THEN (Q.RENAME_TAC [‘MemOp m_’]) (Cases_on `m_`) + >>> SELECT_LT_THEN (Q.RENAME_TAC [‘ThunkOp t_’]) (Cases_on `t_`); val do_app_with_stack = time Q.prove( `do_app op vs (s with stack := z) = @@ -219,8 +220,7 @@ val do_app_with_stack = time Q.prove( ; stack_max := (do_stack op vs (s with stack := z)).stack_max ; peak_heap_length := do_app_peak op vs (s with stack := z) |>)) I (do_app op vs s)`, - cheat (* SLOW *) - (*Cases_on `do_app op vs (s with stack := z)` + Cases_on `do_app op vs (s with stack := z)` \\ cases_on_op_fs `op` \\ TRY (rename [‘EqualConst cc’] \\ Cases_on ‘cc’) \\ ntac 2 ( @@ -232,9 +232,10 @@ val do_app_with_stack = time Q.prove( pair_case_eq,consume_space_def,op_space_reset_def,check_lim_def] \\ TRY (pairarg_tac \\ fs []) \\ rveq \\ fs []) + \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) \\ fs [allowed_op_def] \\ rw [state_component_equality] \\ simp [Once CONJ_COMM] - \\ rw [EQ_IMP_THM] \\ fs[stack_consumed_def,allowed_op_def,PULL_EXISTS]*)); + \\ rw [EQ_IMP_THM] \\ fs[stack_consumed_def,allowed_op_def,PULL_EXISTS]); val do_app_with_stack_and_locals = time Q.prove( `do_app op vs (s with <|locals_size := lsz; stack := z|>) = @@ -244,8 +245,7 @@ val do_app_with_stack_and_locals = time Q.prove( ; stack_max := (do_stack op vs (s with <|locals_size := lsz; stack := z|>)).stack_max ; peak_heap_length := do_app_peak op vs (s with <|locals_size := lsz; stack := z|>) |>)) I (do_app op vs s)`, - cheat (* SLOW *) - (*Cases_on `do_app op vs (s with <|locals_size := lsz; stack := z|>)` + Cases_on `do_app op vs (s with <|locals_size := lsz; stack := z|>)` \\ cases_on_op_fs `op` \\ TRY (rename [‘EqualConst cc’] \\ Cases_on ‘cc’) \\ ntac 2 ( @@ -257,15 +257,15 @@ val do_app_with_stack_and_locals = time Q.prove( pair_case_eq,consume_space_def,op_space_reset_def,check_lim_def] \\ TRY (pairarg_tac \\ fs []) \\ rveq \\ fs []) + \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) \\ fs[allowed_op_def] \\ rw [state_component_equality] \\ simp [Once CONJ_COMM] - \\ rw[EQ_IMP_THM] \\ fs[stack_consumed_def,allowed_op_def]*)); + \\ rw[EQ_IMP_THM] \\ fs[stack_consumed_def,allowed_op_def]); Theorem do_app_aux_with_space: do_app_aux op vs (s with space := z) = map_result (λ(x,y). (x,y with space := z)) I (do_app_aux op vs s) Proof - cheat (* SLOW *) - (*Cases_on `do_app_aux op vs (s with space := z)` + Cases_on `do_app_aux op vs (s with space := z)` \\ cases_on_op_fs `op` \\ TRY (rename [‘EqualConst cc’] \\ Cases_on ‘cc’) \\ ntac 2 ( @@ -276,14 +276,14 @@ Proof semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq, pair_case_eq,consume_space_def,check_lim_def] \\ TRY (pairarg_tac \\ fs []) - \\ rveq \\ fs [] \\ rw [])*) + \\ rveq \\ fs [] \\ rw []) + \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) \\ gvs [] QED Theorem do_app_aux_with_locals: do_app_aux op vs (s with locals := z) = map_result (λ(x,y). (x,y with locals := z)) I (do_app_aux op vs s) Proof - cheat (* SLOW *) - (*Cases_on `do_app_aux op vs (s with locals := z)` + Cases_on `do_app_aux op vs (s with locals := z)` \\ cases_on_op_fs `op` \\ TRY (rename [‘EqualConst cc’] \\ Cases_on ‘cc’) \\ ntac 2 ( @@ -294,7 +294,8 @@ Proof semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq, pair_case_eq,consume_space_def,check_lim_def] \\ TRY (pairarg_tac \\ fs []) - \\ rveq \\ fs [] \\ rw [])*) + \\ rveq \\ fs [] \\ rw []) + \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) \\ gvs [] QED val do_app_with_locals = time Q.prove( @@ -304,8 +305,7 @@ val do_app_with_locals = time Q.prove( ; stack_max := (do_stack op vs (s with locals := z)).stack_max ; peak_heap_length := do_app_peak op vs (s with locals := z)|>)) I (do_app op vs s)`, - cheat (* SLOW *) - (*Cases_on `do_app op vs (s with locals := z)` + Cases_on `do_app op vs (s with locals := z)` \\ cases_on_op_fs `op` \\ TRY (rename [‘EqualConst cc’] \\ Cases_on ‘cc’) \\ ntac 2 ( @@ -317,9 +317,10 @@ val do_app_with_locals = time Q.prove( pair_case_eq,consume_space_def,check_lim_def] \\ TRY (pairarg_tac \\ fs []) \\ rveq \\ fs []) + \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) \\ gvs [] \\ fs [allowed_op_def] \\ rw [state_component_equality] \\ simp [Once CONJ_COMM] - \\ rw[EQ_IMP_THM] \\ fs[stack_consumed_def,allowed_op_def]*)); + \\ rw[EQ_IMP_THM] \\ fs[stack_consumed_def,allowed_op_def]); Theorem do_app_aux_err: do_app_aux op vs s = Rerr e ⇒ (e = Rabort Rtype_error) @@ -439,8 +440,8 @@ Proof EVAL_TAC \\ rw [] QED -val do_app_swap_tac = cheat (* SLOW *); - (*strip_tac +val do_app_swap_tac = + strip_tac \\ cases_on_op_fs ‘op’ \\ TRY (rename [‘EqualConst cc’] \\ Cases_on ‘cc’) \\ rw [do_app_def,do_stack_def @@ -462,8 +463,9 @@ val do_app_swap_tac = cheat (* SLOW *); , limits_component_equality,stack_consumed_def] \\ fs [data_spaceTheory.op_space_req_def,stack_consumed_def] \\ rfs [data_spaceTheory.op_space_req_def] - \\ simp [Once CONJ_COMM] \\ NO_TAC) \\ - rpt(PURE_TOP_CASE_TAC \\ fs[] \\ rveq) \\ fs[state_component_equality,stack_consumed_def];*) + \\ simp [Once CONJ_COMM] \\ NO_TAC) + \\ rpt(PURE_TOP_CASE_TAC \\ fs[] \\ rveq) \\ fs[state_component_equality,stack_consumed_def] + \\ gvs [AllCaseEqs()]; Theorem do_app_aux_safe_peak_swap: @@ -910,8 +912,43 @@ Proof \\ every_case_tac \\ fs[state_component_equality,evaluate_safe_def,evaluate_peak_def]) (* Assign *) - >- ( - Cases_on `op = ThunkOp ForceThunk` >- cheat (* doesn't work *) + >- (Cases_on `op = ThunkOp ForceThunk` + >- (simp [evaluate_def] + \\ gvs [op_requires_names_def, op_space_reset_def] + \\ IF_CASES_TAC + \\ gvs [AllCaseEqs(), cut_state_opt_def] + \\ ntac 2 (CASE_TAC \\ gvs []) + \\ Cases_on `get_vars args x'.locals` \\ gvs [] + \\ Cases_on `dest_thunk x'' x'.refs` \\ gvs [] + \\ Cases_on `t` \\ gvs [PULL_EXISTS] + >- ( + gvs [set_var_def, cut_state_def, cut_env_def, AllCaseEqs()] \\ rw [] + \\ gvs [state_component_equality]) + \\ IF_CASES_TAC \\ gvs [] + >- ( + gvs [flush_state_def] \\ rw [] + \\ gvs [cut_state_def, AllCaseEqs()] + \\ gvs [state_component_equality]) + \\ ntac 2 (CASE_TAC \\ gvs []) + >- ( + gvs [set_var_def, cut_state_def, cut_env_def, AllCaseEqs()] \\ rw [] + \\ first_x_assum drule + \\ disch_then $ qspec_then `lsz` assume_tac \\ gvs [] + \\ gvs [state_component_equality]) + \\ CASE_TAC \\ gvs [] + >- ( + CASE_TAC + \\ gvs [set_var_def, cut_state_def, cut_env_def, AllCaseEqs()] + \\ rw [] + \\ first_x_assum $ drule_then $ qspec_then `lsz` assume_tac + \\ gvs [] + \\ gvs [state_component_equality]) + \\ TOP_CASE_TAC \\ gvs [] + >- ( + gvs [jump_exc_def, AllCaseEqs(), PULL_EXISTS] + \\ gvs [cut_state_def, cut_env_def, AllCaseEqs()] \\ rw []) + \\ TOP_CASE_TAC \\ gvs [] + \\ gvs [cut_state_def, cut_env_def, AllCaseEqs()]) \\ fs[evaluate_def] \\ every_case_tac \\ fs[set_var_def,cut_state_opt_with_const,do_app_with_stack_and_locals] @@ -1359,14 +1396,13 @@ Triviality evaluate_locals_LN_lemma: ((SND (evaluate (c,s))).locals = LN) \/ ?t. FST (evaluate (c,s)) = SOME (Rerr(Rraise t)) Proof - cheat (* doesn't work *) - (*recInduct evaluate_ind \\ REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[evaluate_def] + recInduct evaluate_ind \\ REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[evaluate_def] \\ every_case_tac \\ full_simp_tac(srw_ss())[call_env_def,flush_state_def,fromList_def] \\ imp_res_tac do_app_err >> full_simp_tac(srw_ss())[] >> rev_full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] \\ full_simp_tac(srw_ss())[LET_DEF] \\ SRW_TAC [] [] \\ full_simp_tac(srw_ss())[] \\ rpt(TOP_CASE_TAC >> fs[] >> rveq) \\ fs[markerTheory.Abbrev_def] - \\ rpt(TOP_CASE_TAC >> fs[] >> rveq)*) + \\ rpt(TOP_CASE_TAC >> fs[] >> rveq) QED Theorem evaluate_locals_LN: @@ -1677,6 +1713,7 @@ Proof semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq, pair_case_eq,consume_space_def,size_of_heap_with_clock,check_lim_def] \\ rveq \\ fs [] \\ rw []) + \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) \\ gvs [] QED Theorem do_app_change_clock: @@ -1697,6 +1734,7 @@ Proof semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq, pair_case_eq,consume_space_def,size_of_heap_with_clock,check_lim_def] >> rveq >> fs [] >> rw []) + \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) \\ gvs [] QED Theorem do_app_change_clock_err: @@ -1717,6 +1755,7 @@ Proof semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq, pair_case_eq,consume_space_def,check_lim_def] >> rveq >> fs [] >> rw []) + \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) \\ gvs [] QED Theorem cut_state_eq_some: @@ -1755,7 +1794,7 @@ Proof \\ Cases_on `cut_state x s` \\ gvs [] \\ gvs [cut_state_def] \\ Cases_on `cut_env x s.locals` \\ gvs [] - \\ gvs [AllCaseEqs()]) + \\ gvs [AllCaseEqs(), set_var_def]) \\ fs [do_app_aux_def,list_case_eq,option_case_eq,v_case_eq,cut_state_opt_def,cut_state_def , bool_case_eq,ffiTheory.call_FFI_def,semanticPrimitivesTheory.result_case_eq , with_fresh_ts_def,bvlSemTheory.ref_case_eq @@ -1849,6 +1888,7 @@ Proof semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq, pair_case_eq,consume_space_def,check_lim_def] >> rveq >> fs []) + \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) \\ gvs [] QED Theorem call_env_const[simp]: @@ -2086,6 +2126,7 @@ Proof pair_case_eq,consume_space_def,op_space_reset_def,data_spaceTheory.op_space_req_def, UNCURRY_EQ] \\ rw [] \\ fs [state_component_equality] \\ rw [] + \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) \\ gvs [] QED Theorem evaluate_safe_for_space_mono: @@ -2097,11 +2138,12 @@ Proof rename1 `op = ThunkOp ForceThunk` \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs [] >- ( gvs [op_requires_names_def, op_space_reset_def] - \\ Cases_on `names_opt` \\ gvs [cut_state_opt_def, cut_state_def] - \\ gvs [AllCaseEqs()]) - \\ gvs [cut_state_opt_def, cut_state_def, AllCaseEqs()] - \\ gvs [set_var_def, flush_state_def] - \\ imp_res_tac do_app_safe_for_space_mono \\ gvs []) + \\ Cases_on `names_opt` + \\ gvs [cut_state_opt_def, cut_state_def, AllCaseEqs()] + \\ gvs [set_var_def, flush_state_def]) + \\ gvs [cut_state_opt_def, cut_state_def, AllCaseEqs()] + \\ gvs [set_var_def, flush_state_def] + \\ imp_res_tac do_app_safe_for_space_mono \\ gvs []) \\ fs [CaseEq"option",cut_state_opt_def,CaseEq"result",pair_case_eq, cut_state_def,jump_exc_def,CaseEq"stack",CaseEq"list"] \\ fs [] \\ rveq \\ fs [set_var_def,call_env_def,flush_state_def,dec_clock_def,add_space_def] @@ -2145,7 +2187,7 @@ Proof AllCaseEqs(), PULL_EXISTS] \\ gvs [cut_state_opt_def, cut_state_def, AllCaseEqs()] \\ TRY (last_x_assum $ qspec_then `limits'` assume_tac \\ gvs []) - \\ gvs [state_component_equality]) + \\ gvs [state_component_equality, set_var_def, flush_state_def]) \\ fs [evaluate_def] \\ full_cases >> full_fs \\ fs [] \\ rfs[] @@ -2320,7 +2362,7 @@ Proof \\ TRY ( last_x_assum $ drule_then $ qspecl_then [`lsz`, `sfs`] assume_tac \\ gvs []) - \\ gvs [state_component_equality]) + \\ gvs [state_component_equality, set_var_def, flush_state_def]) \\ fs [evaluate_def] \\ full_cases >> full_fs \\ fs [] \\ rfs[] @@ -2560,9 +2602,10 @@ Proof >- ((* Assign *) Cases_on `op = ThunkOp ForceThunk` >- gvs [op_requires_names_def, op_space_reset_def, evaluate_def, - cut_state_opt_def, cut_state_def, AllCaseEqs()] - \\ fs[evaluate_def,CaseEq"bool",CaseEq"option",CaseEq"result",CaseEq"prod", - cut_state_opt_def,cut_state_def,set_var_def,get_vars_def] >> + cut_state_opt_def, cut_state_def, AllCaseEqs(), set_var_def, + flush_state_def] >> + fs[evaluate_def,CaseEq"bool",CaseEq"option",CaseEq"result",CaseEq"prod", + cut_state_opt_def,cut_state_def,set_var_def,get_vars_def] >> rveq >> fs[flush_state_def] >> imp_res_tac do_app_stack_max >> fs[]) >- ((* Tick *) @@ -2659,6 +2702,7 @@ Proof pair_case_eq,consume_space_def,op_space_reset_def,check_lim_def, CaseEq"closLang$op",ELIM_UNCURRY,size_of_heap_def,stack_to_vs_def] >> rveq >> fs[]) + >> TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) >> gvs [] QED @@ -2697,7 +2741,8 @@ Proof semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq, pair_case_eq,consume_space_def,op_space_reset_def,check_lim_def, CaseEq"closLang$op",ELIM_UNCURRY,size_of_heap_def,stack_to_vs_def] >> - rveq >> fs[] + rveq >> fs[] >> + TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) >> gvs [] QED Theorem pop_env_safe_for_space: @@ -2745,7 +2790,7 @@ Proof $ qspec_then `t with <|locals := insert 0 v LN; clock := t.clock - 1|>` assume_tac >> gvs []) >> - gvs [cc_co_only_diff_def]) >> + gvs [cc_co_only_diff_def, set_var_def, flush_state_def]) >> fs[evaluate_def] >> IF_CASES_TAC >- (fs[] >> rveq >> fs[]) >> @@ -2888,7 +2933,9 @@ Proof CaseEq"closLang$op",ELIM_UNCURRY,size_of_heap_def,stack_to_vs_def, stack_consumed_def ] >> - rveq >> fs[stack_consumed_def,allowed_op_def] >> + rveq >> + fs[stack_consumed_def,allowed_op_def,data_spaceTheory.op_space_req_def] >> + TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) >> gvs [] >> imp_res_tac the_le_IMP_option_le >> fs[option_le_max,option_le_max_right] >> rpt (pop_assum mp_tac)>> @@ -2911,7 +2958,7 @@ Proof Cases_on `op = ThunkOp ForceThunk` >- ( fs [op_requires_names_def, op_space_reset_def, cut_state_opt_def, cut_state_def, evaluate_def, AllCaseEqs()] >> - gvs []) >> + gvs [set_var_def, flush_state_def]) >> fs[evaluate_def,CaseEq"bool",CaseEq"option",CaseEq"result",CaseEq"prod", cut_state_opt_def,cut_state_def,set_var_def,get_vars_def] >> rveq >> fs[flush_state_def] >> diff --git a/compiler/backend/semantics/dataSemScript.sml b/compiler/backend/semantics/dataSemScript.sml index de4638b16b..14a53d2e02 100644 --- a/compiler/backend/semantics/dataSemScript.sml +++ b/compiler/backend/semantics/dataSemScript.sml @@ -987,6 +987,18 @@ Definition do_app_aux_def: then Rval (Boolv (i < &n),s) else Error | _ => Error) | (MemOp ConfigGC,[Number _; Number _]) => (Rval (Unit, s)) + | (ThunkOp th_op,vs) => + (case (th_op,vs) of + | (AllocThunk m, [v]) => + (let ptr = (LEAST ptr. ptr ∉ domain s.refs) in + Rval (RefPtr F ptr, + s with refs := insert ptr (Thunk m v) s.refs)) + | (UpdateThunk m, [RefPtr _ ptr; v]) => + (case lookup ptr s.refs of + | SOME (Thunk NotEvaluated _) => + Rval (Unit,s with refs := insert ptr (Thunk m v) s.refs) + | _ => Error) + | _ => Error) | _ => Error End @@ -1240,10 +1252,10 @@ Definition evaluate_def: (case dest_thunk xs s.refs of | BadRef => (SOME (Rerr (Rabort Rtype_error)),s) | NotThunk => (SOME (Rerr (Rabort Rtype_error)),s) - | IsThunk Evaluated v => (SOME (Rval v),s) + | IsThunk Evaluated v => (NONE,set_var dest v s) | IsThunk NotEvaluated f => if s.clock = 0 then - (SOME (Rerr (Rabort Rtimeout_error)),s) + (SOME (Rerr (Rabort Rtimeout_error)), flush_state T s) else case evaluate ( AppUnit,s with <| locals := (insert 0 f LN); @@ -1251,7 +1263,8 @@ Definition evaluate_def: | (SOME (Rval x),s) => (case update_thunk xs s.refs [x] of | NONE => (SOME (Rerr (Rabort Rtype_error)),s) - | SOME refs => (SOME (Rval x),s with refs := refs)) + | SOME refs => + (NONE,set_var dest x (s with refs := refs))) | (err,s) => (err,s)) else (case do_app op xs s of From 9482cab4edfee7f5b837bc51e62144e8678c6cb9 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Mon, 21 Jul 2025 12:54:16 +0300 Subject: [PATCH 019/112] progress on AppUnit in bvi and data --- .../backend/proofs/bvi_to_dataProofScript.sml | 250 ++++++++++++++---- compiler/backend/semantics/bviSemScript.sml | 4 - compiler/backend/semantics/bvlSemScript.sml | 4 +- compiler/backend/semantics/dataSemScript.sml | 28 +- 4 files changed, 218 insertions(+), 68 deletions(-) diff --git a/compiler/backend/proofs/bvi_to_dataProofScript.sml b/compiler/backend/proofs/bvi_to_dataProofScript.sml index 560456226c..c6c8a7d801 100644 --- a/compiler/backend/proofs/bvi_to_dataProofScript.sml +++ b/compiler/backend/proofs/bvi_to_dataProofScript.sml @@ -683,6 +683,31 @@ Proof \\ rveq \\ fs [state_component_equality] QED +Theorem evaluate_push_Seq: + evaluate ((if tail then Seq p (Return n) else p), t) = + evaluate (Seq p (if tail then Return n else Skip), t) +Proof + Cases_on `tail` \\ rw [evaluate_def] + \\ Cases_on `evaluate (p,t)` \\ rw [] +QED + +Theorem AppUnit_eq: + evaluate (AppUnit,t) = + evaluate (Seq (Seq (Seq Skip (Assign 1 (BlockOp (Cons 0)) [] NONE)) + (Seq Skip + (Seq + (Seq (Seq Skip (Assign 2 (IntOp (Const 0)) [] NONE)) + Skip) (Assign 3 (MemOp El) [0; 2] NONE)))) + (Call NONE NONE [1; 0; 3] NONE),t) +Proof + rw [AppUnit_def] + \\ simp [evaluate_def, dataLangTheory.op_requires_names_def, + dataLangTheory.op_space_reset_def, cut_state_opt_def, get_vars_def, + do_app_def, do_space_def, data_spaceTheory.op_space_req_def, + do_app_aux_def, set_var_def, flush_state_def, do_stack_def, + backend_commonTheory.small_enough_int_def] +QED + Theorem compile_correct: ∀xs env s1 res s2 t1 n corr tail live. evaluate (xs,env,s1) = (res,s2) ∧ @@ -991,60 +1016,180 @@ Proof \\ IMP_RES_TAC get_vars_reverse \\ rveq \\ fs []) \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs [] >- ( - gvs [iAssign_def, dataLangTheory.op_requires_names_def, - dataLangTheory.op_space_reset_def] - \\ Cases_on `tail = F` \\ gvs [] + gvs [evaluate_push_Seq] + \\ gvs [iAssign_def, dataLangTheory.op_requires_names_def, + dataLangTheory.op_space_reset_def] + \\ gvs [evaluate_def, cut_state_opt_def, cut_state_def, cut_env_def] + \\ gvs [oneline bviSemTheory.dest_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ Cases_on `x0` \\ gvs [data_to_bvi_v_def] >- ( - gvs [evaluate_def, cut_state_opt_def, cut_state_def, cut_env_def] - \\ gvs [oneline bviSemTheory.dest_thunk_def, AllCaseEqs(), PULL_EXISTS] - \\ Cases_on `x0` \\ gvs [data_to_bvi_v_def] + `lookup n' (map data_to_bvi_ref t2.refs) = + SOME (Thunk Evaluated v)`by gvs [state_rel_def] + \\ gvs [lookup_map] + \\ Cases_on `z` + \\ gvs [data_to_bvi_ref_def, dest_thunk_def, set_var_def] + \\ Cases_on `tail` \\ gvs [evaluate_def] + >- gvs [get_var_def, flush_state_def, data_to_bvi_result_def, + state_rel_def] + \\ rw [] + >- gvs [state_rel_def] + >- (unabbrev_all_tac \\ gvs [lookup_insert, lookup_inter]) >- ( - `∃v. lookup n' (map data_to_bvi_ref t2.refs) = - SOME (Thunk Evaluated v)`by gvs [state_rel_def] - \\ gvs [lookup_map] - \\ Cases_on `z` - \\ gvs [data_to_bvi_ref_def, dest_thunk_def, set_var_def] \\ rw [] - >- gvs [state_rel_def] - >- (unabbrev_all_tac \\ gvs [lookup_insert, lookup_inter]) - >- cheat - >- ( - unabbrev_all_tac - \\ gvs [lookup_insert, AllCaseEqs(), lookup_inter] - \\ first_x_assum drule \\ rw []) - >- ( - unabbrev_all_tac - \\ gvs [lookup_insert] \\ rw [] - >- gvs [state_rel_def] - \\ gvs [lookup_inter, AllCaseEqs(), lookup_list_to_num_set] - \\ Cases_on `MEM k live` \\ gvs []) - >- gvs [jump_exc_def] - >- gvs [var_corr_def, get_var_def, get_vars_def, lookup_map, - state_rel_def, data_to_bvi_ref_def]) + unabbrev_all_tac + \\ gvs [var_corr_def, get_var_def, LIST_REL_EL_EQN, lookup_map, + lookup_insert, lookup_inter] + \\ gvs [lookup_inter_EQ, lookup_list_to_num_set, EL_MAP] + \\ rw [] + \\ res_tac \\ gvs [MEM_EL]) >- ( - `∃v. lookup n' (map data_to_bvi_ref t2.refs) = - SOME (Thunk NotEvaluated v)`by gvs [state_rel_def] - \\ gvs [lookup_map] - \\ Cases_on `z` - \\ gvs [data_to_bvi_ref_def, dest_thunk_def, set_var_def] \\ rw [] - \\ `r.clock = t2.clock` by gvs [state_rel_def] - \\ gvs [flush_state_def, data_to_bvi_result_def, state_rel_def]) + unabbrev_all_tac + \\ gvs [lookup_insert, AllCaseEqs(), lookup_inter] + \\ first_x_assum drule \\ rw []) >- ( - `∃v. lookup n' (map data_to_bvi_ref t2.refs) = - SOME (Thunk NotEvaluated v)`by gvs [state_rel_def] + unabbrev_all_tac + \\ gvs [lookup_insert] \\ rw [] + >- gvs [state_rel_def] + \\ gvs [lookup_inter, AllCaseEqs(), lookup_list_to_num_set] + \\ Cases_on `MEM k live` \\ gvs []) + >- gvs [jump_exc_def] + >- gvs [var_corr_def, get_var_def, get_vars_def, lookup_map, + state_rel_def, data_to_bvi_ref_def]) + >- ( + `lookup n' (map data_to_bvi_ref t2.refs) = + SOME (Thunk NotEvaluated v)` by gvs [state_rel_def] + \\ gvs [lookup_map] + \\ Cases_on `z` + \\ gvs [data_to_bvi_ref_def, dest_thunk_def, set_var_def] + \\ `r.clock = t2.clock` by gvs [state_rel_def] + \\ gvs [flush_state_def, data_to_bvi_result_def, state_rel_def]) + >- ( + `lookup n' (map data_to_bvi_ref t2.refs) = + SOME (Thunk NotEvaluated v)`by gvs [state_rel_def] + \\ gvs [lookup_map] + \\ Cases_on `z` + \\ gvs [data_to_bvi_ref_def, dest_thunk_def, set_var_def] + \\ `r.clock = t2.clock` by gvs [state_rel_def] \\ gvs [PULL_EXISTS] + \\ `state_rel (dec_clock 1 r) + (t2 with <| + locals := insert 0 a LN; + clock := t2.clock - 1 |>)` + by gvs [bviSemTheory.dec_clock_def, dec_clock_def, state_rel_def] + \\ last_x_assum $ drule_at (Pat `state_rel _ _`) \\ gvs [] + \\ disch_then $ qspecl_then [`1`, `[0]`, `T`, `[]`] mp_tac + \\ impl_tac + >- gvs [var_corr_def, get_var_def, dec_clock_def, lookup_map, + lookup_insert] + \\ strip_tac \\ gvs [] + \\ Cases_on `pres` \\ gvs [] + \\ gvs [data_to_bvi_v_def, SF ETA_ss] + \\ `∃ts tag w1 ws1. a = Block ts tag (w1::ws1)` by cheat \\ gvs [] + \\ `∃loc. w1 = CodePtr loc` by cheat \\ gvs [] + \\ gvs [bviSemTheory.AppUnit_def, compile_def] + \\ gvs [any_el_def, dataLangTheory.mk_ticks_def] + \\ gvs [iAssign_def, dataLangTheory.op_requires_names_def, + dataLangTheory.op_space_reset_def, + data_spaceTheory.op_space_req_def] + \\ gvs [AppUnit_eq, PULL_EXISTS] + \\ reverse $ Cases_on `x` \\ gvs [] + >- (Cases_on `e` \\ gvs [data_to_bvi_result_def]) + \\ imp_res_tac evaluate_locals_LN \\ gvs [] + \\ qpat_x_assum `evaluate _ = (SOME x,_)` kall_tac + \\ gvs [data_to_bvi_result_def] + \\ qpat_x_assum `update_thunk _ _ _ = SOME _` mp_tac + \\ simp [bviSemTheory.update_thunk_def] \\ TOP_CASE_TAC + \\ simp [bviSemTheory.store_thunk_def] + \\ ntac 3 (TOP_CASE_TAC \\ simp []) \\ strip_tac \\ gvs [] + \\ simp [update_thunk_def] + \\ `dest_thunk [a] t2'.refs = NotThunk` by ( + gvs [state_rel_def, oneline bviSemTheory.dest_thunk_def, + oneline dest_thunk_def] + \\ CASE_TAC \\ gvs [data_to_bvi_v_def] + \\ CASE_TAC \\ gvs [] \\ gvs [lookup_map] - \\ Cases_on `z` - \\ gvs [data_to_bvi_ref_def, dest_thunk_def, set_var_def] \\ rw [] - \\ `r.clock = t2.clock` by gvs [state_rel_def] \\ gvs [PULL_EXISTS] - \\ `state_rel (dec_clock 1 r) (dec_clock t2)` - by gvs [bviSemTheory.dec_clock_def, dec_clock_def, state_rel_def] - \\ last_x_assum $ drule_at (Pat `state_rel _ _`) \\ gvs [] - \\ disch_then $ qspecl_then [`n`, `[n']`, `F`, `live`] mp_tac - \\ impl_tac >- cheat \\ rw [] - \\ cheat) - >- cheat)) - \\ reverse(Cases_on `do_app op (REVERSE a) r`) \\ full_simp_tac(srw_ss())[] >- ( - cheat - (*imp_res_tac bviPropsTheory.do_app_err >> full_simp_tac(srw_ss())[] >> + \\ ntac 2 (CASE_TAC \\ gvs []) + \\ gvs [data_to_bvi_ref_def]) \\ gvs [] + \\ simp [store_thunk_def] + \\ `∀n. FLOOKUP s''.refs n = lookup n (map data_to_bvi_ref t2'.refs)` + by gvs [state_rel_def] \\ gvs [] + \\ pop_assum $ qspec_then `n'` assume_tac \\ gvs [] + \\ gvs [lookup_map] + \\ Cases_on `z` \\ gvs [data_to_bvi_ref_def] + \\ Cases_on `tail` \\ gvs [evaluate_def] + >- ( + gvs [get_var_def, state_rel_def, flush_state_def, lookup_map, + lookup_insert, FLOOKUP_UPDATE, data_to_bvi_result_def] + \\ rw [] \\ gvs [data_to_bvi_ref_def]) + \\ gvs [lookup_insert, map_insert, var_corr_def, get_var_def] + \\ conj_tac + >- ( + gvs [state_rel_def, lookup_map, lookup_insert] + \\ rw [] + >- gvs [data_to_bvi_ref_def, FLOOKUP_DEF] + \\ gvs [FLOOKUP_UPDATE]) + \\ conj_tac + >- ( + rw [] + \\ unabbrev_all_tac \\ gvs [] + \\ gvs [lookup_inter]) + \\ conj_tac + >- ( + `¬MEM n1 corr` by ( + qpat_x_assum `∀k. n1 ≤ k ⇒ _` assume_tac + \\ qpat_x_assum `LIST_REL _ corr _` assume_tac + \\ CCONTR_TAC \\ gvs [] + \\ gvs [MEM_EL, LIST_REL_EL_EQN] + \\ first_x_assum drule \\ gvs [lookup_map, EL_MAP]) + \\ gvs [LIST_REL_EL_EQN, MEM_EL] + \\ rw [] + \\ unabbrev_all_tac + \\ gvs [lookup_map, lookup_inter_EQ, lookup_list_to_num_set, EL_MAP, + MEM_EL] + \\ metis_tac []) + \\ conj_tac + >- ( + rw [] + \\ unabbrev_all_tac + \\ gvs [lookup_inter_alt] + \\ res_tac + \\ fs []) + \\ conj_tac + >- ( + rw [] + \\ unabbrev_all_tac + \\ gvs [lookup_inter_EQ, lookup_list_to_num_set, EL_MAP, MEM_EL] + \\ metis_tac []) + \\ gvs [jump_exc_def] + \\ rpt (CASE_TAC \\ gvs [])) + >- ( + `lookup n' (map data_to_bvi_ref t2.refs) = + SOME (Thunk NotEvaluated v)` by gvs [state_rel_def] + \\ gvs [lookup_map] + \\ Cases_on `z` + \\ gvs [data_to_bvi_ref_def, dest_thunk_def, set_var_def] + \\ `r.clock = t2.clock` by gvs [state_rel_def] \\ gvs [PULL_EXISTS] + \\ `state_rel (dec_clock 1 r) + (t2 with <| + locals := insert 0 a LN; + clock := t2.clock - 1 |>)` + by gvs [bviSemTheory.dec_clock_def, dec_clock_def, state_rel_def] + \\ last_x_assum $ drule_at (Pat `state_rel _ _`) \\ gvs [] + \\ disch_then $ qspecl_then [`1`, `[0]`, `T`, `[]`] mp_tac + \\ impl_tac + >- (gvs [var_corr_def, get_var_def, dec_clock_def, lookup_map, + lookup_insert] + \\ rw [] \\ gvs [jump_exc_def, AllCaseEqs()]) + \\ gvs [] \\ strip_tac \\ gvs [] + \\ Cases_on `pres` \\ gvs [] + \\ Cases_on `x` \\ gvs [data_to_bvi_result_def] + \\ gvs [bviSemTheory.AppUnit_def, compile_def] + \\ gvs [any_el_def, dataLangTheory.mk_ticks_def] + \\ gvs [iAssign_def, dataLangTheory.op_requires_names_def, + dataLangTheory.op_space_reset_def, + data_spaceTheory.op_space_req_def] + \\ gvs [AppUnit_eq, PULL_EXISTS] + \\ metis_tac [])) + \\ reverse(Cases_on `do_app op (MAP data_to_bvi_v (REVERSE z')) r`) \\ full_simp_tac(srw_ss())[] >- ( + imp_res_tac bviPropsTheory.do_app_err >> full_simp_tac(srw_ss())[] >> rveq >> IF_CASES_TAC >> fs[dataSemTheory.evaluate_def,iAssign_def,dataLangTheory.op_requires_names_def, cut_state_opt_def,cut_state_def,cut_env_def] >> @@ -1053,8 +1198,8 @@ Proof rpt(PURE_CASE_TAC >> fs[data_to_bvi_v_def,GSYM MAP_REVERSE] >> rveq) >> fs[state_rel_def] >> rfs[] >> fs [data_to_bvi_result_def] >> - fs[call_env_def,flush_state_def,data_to_bvi_ref_def,lookup_map]*)) - \\ PairCases_on `a'` \\ full_simp_tac(srw_ss())[] \\ REV_FULL_SIMP_TAC std_ss [] + fs[call_env_def,flush_state_def,data_to_bvi_ref_def,lookup_map]) + \\ PairCases_on `a` \\ full_simp_tac(srw_ss())[] \\ REV_FULL_SIMP_TAC std_ss [] \\ rpt var_eq_tac >> full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[LET_DEF,evaluate_def,iAssign_def] \\ (fn (hs,goal) => (reverse (sg `let tail = F in ^goal`)) @@ -1063,7 +1208,7 @@ Proof \\ reverse (Cases_on `tail`) THEN1 METIS_TAC [] \\ full_simp_tac(srw_ss())[evaluate_def,LET_DEF] \\ REV_FULL_SIMP_TAC std_ss [] \\ Cases_on `pres` \\ full_simp_tac(srw_ss())[] - \\ `∃z2. get_var n1 t2'.locals = SOME z2 ∧ a'0 = data_to_bvi_v z2` + \\ `∃z2. get_var n1 t2'.locals = SOME z2 ∧ a0 = data_to_bvi_v z2` by FULL_SIMP_TAC (srw_ss()) [var_corr_def,lookup_map,get_var_def] \\ full_simp_tac(srw_ss())[var_corr_def,call_env_def,flush_state_def,state_rel_def,data_to_bvi_result_def]) \\ simp[] @@ -1092,6 +1237,7 @@ Proof \\ Cases_on`h` \\ fs[set_var_def,lookup_insert,var_corr_def,state_rel_def,o_DEF,get_var_def,lookup_insert,lookup_map] \\ qmatch_goalsub_abbrev_tac`fromAList progs1` \\ qmatch_goalsub_abbrev_tac`union t2.code (fromAList progs2)` + \\ gvs [PULL_EXISTS] \\ conj_tac >- ( ntac 2 (pop_assum kall_tac) \\ rveq \\ diff --git a/compiler/backend/semantics/bviSemScript.sml b/compiler/backend/semantics/bviSemScript.sml index 2f4d8dc369..1522a14fc8 100644 --- a/compiler/backend/semantics/bviSemScript.sml +++ b/compiler/backend/semantics/bviSemScript.sml @@ -195,14 +195,10 @@ End Definition AppUnit_def: AppUnit = - If (Op (BlockOp Equal) - [Op (IntOp (Const 0)) []; - Op (MemOp El) [Op (IntOp (Const 1)) []; Var 0]]) (Call 0 NONE [Op (BlockOp (Cons 0)) []; Var 0; Op (MemOp El) [Op (IntOp (Const 0)) []; Var 0]] NONE) - (Call 0 (SOME num_stubs) [Op (BlockOp (Cons 0)) []; Var 0] NONE) End diff --git a/compiler/backend/semantics/bvlSemScript.sml b/compiler/backend/semantics/bvlSemScript.sml index 79b126bea2..f87acaee2a 100644 --- a/compiler/backend/semantics/bvlSemScript.sml +++ b/compiler/backend/semantics/bvlSemScript.sml @@ -519,9 +519,9 @@ End Definition AppUnit_def: AppUnit = - If (Op (BlockOp Equal) [mk_const 0; mk_el (Var 0) (mk_const 1)]) + (*If (Op (BlockOp Equal) [mk_const 0; mk_el (Var 0) (mk_const 1)])*) (Call 0 NONE [mk_unit; Var 0; mk_el (Var 0) (mk_const 0)]) - (Call 0 (SOME 0) [mk_unit; Var 0]) + (*(Call 0 (SOME 0) [mk_unit; Var 0])*) End (* The evaluation is defined as a clocked functional version of diff --git a/compiler/backend/semantics/dataSemScript.sml b/compiler/backend/semantics/dataSemScript.sml index 14a53d2e02..9fc46d1995 100644 --- a/compiler/backend/semantics/dataSemScript.sml +++ b/compiler/backend/semantics/dataSemScript.sml @@ -1231,7 +1231,11 @@ Definition update_thunk_def: End Definition AppUnit_def: - AppUnit = ARB + AppUnit = + Seq (Assign 1 (BlockOp (Cons 0)) [] NONE) $ + Seq (Assign 2 (IntOp (Const 0)) [] NONE) $ + Seq (Assign 3 (MemOp El) [0; 2] NONE) + (Call NONE NONE [1; 0; 3] NONE) End Definition evaluate_def: @@ -1258,13 +1262,16 @@ Definition evaluate_def: (SOME (Rerr (Rabort Rtimeout_error)), flush_state T s) else case evaluate ( - AppUnit,s with <| locals := (insert 0 f LN); - clock := (s.clock - 1) |>) of - | (SOME (Rval x),s) => - (case update_thunk xs s.refs [x] of - | NONE => (SOME (Rerr (Rabort Rtype_error)),s) + AppUnit,s with <| + clock := s.clock - 1; + locals := insert 0 f LN |>) of + | (SOME (Rval x),s1) => + (case update_thunk xs s1.refs [x] of + | NONE => (SOME (Rerr (Rabort Rtype_error)),s1) | SOME refs => - (NONE,set_var dest x (s with refs := refs))) + (NONE,set_var dest x (s1 with + <| refs := refs; + locals := s.locals |>))) | (err,s) => (err,s)) else (case do_app op xs s of @@ -1339,16 +1346,17 @@ Definition evaluate_def: | (NONE,s) => (SOME (Rerr(Rabort Rtype_error)),s) | res => res))))) Termination - cheat - (*WF_REL_TAC `(inv_image (measure I LEX measure prog_size) + simp [AppUnit_def] + \\ WF_REL_TAC `(inv_image (measure I LEX measure prog_size) (\(xs,s). (s.clock,xs)))` \\ rpt strip_tac \\ simp[dec_clock_def] \\ imp_res_tac fix_clock_IMP \\ imp_res_tac (GSYM fix_clock_IMP) \\ FULL_SIMP_TAC (srw_ss()) [set_var_def,push_env_clock, call_env_def,LET_THM] + >- gvs [op_requires_names_def, cut_state_opt_def, AllCaseEqs(), cut_state_def] >- fs [LESS_OR_EQ,dec_clock_def] - \\ decide_tac*) + \\ decide_tac End val evaluate_ind = theorem"evaluate_ind"; From d57fa6d362cd991a0204e3969cbb32084c134d16 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Mon, 21 Jul 2025 14:14:09 +0300 Subject: [PATCH 020/112] fix `data_liveProof` --- .../backend/proofs/data_liveProofScript.sml | 27 ++++++++++++++----- 1 file changed, 20 insertions(+), 7 deletions(-) diff --git a/compiler/backend/proofs/data_liveProofScript.sml b/compiler/backend/proofs/data_liveProofScript.sml index 276d00b757..a36cd9c5dd 100644 --- a/compiler/backend/proofs/data_liveProofScript.sml +++ b/compiler/backend/proofs/data_liveProofScript.sml @@ -240,20 +240,33 @@ Proof \\ qmatch_asmsub_abbrev_tac `state_rel s t1 xx` \\ `state_rel (s with <|locals := insert 0 v LN; clock := t1.clock - 1|>) - (t1 with <|locals := insert 0 v LN; clock := t1.clock - 1|>) xx` + (t1 with <|locals := insert 0 v LN; clock := t1.clock - 1|>) + (insert 0 () LN)` by gvs [state_rel_def] \\ gvs [] - \\ last_x_assum $ drule_then $ qspec_then `xx` assume_tac \\ gvs [] - \\ `(AppUnit,xx) = compile AppUnit xx` by cheat \\ gvs [] - \\ unabbrev_all_tac \\ gvs [] - \\ first_x_assum drule \\ rw [] + \\ last_x_assum drule \\ rw [] + \\ pop_assum $ qspec_then `l2` assume_tac \\ gvs [] + \\ `∀s. (AppUnit,insert 0 () LN) = compile AppUnit s` by ( + simp [AppUnit_def, compile_def, is_pure_def, list_insert_def, + list_to_num_set_def, lookup_insert] + \\ simp [insert_compute, delete_compute, mk_BS_def]) \\ Cases_on `q = SOME (Rerr (Rabort Rtype_error))` \\ gvs [] \\ qpat_x_assum `_ ⇒ _` mp_tac \\ impl_tac >- (rw [] \\ gvs [jump_exc_def, AllCaseEqs(), state_rel_def]) \\ rw [] \\ gvs [] \\ gvs [AllCaseEqs(), PULL_EXISTS] - \\ first_x_assum (irule_at Any o GSYM) \\ gvs [PULL_EXISTS] - \\ cheat) + >- metis_tac [] + >- ( + first_x_assum (irule_at Any o GSYM) \\ gvs [PULL_EXISTS] + \\ qpat_x_assum `update_thunk _ _ _ = SOME _` mp_tac + \\ simp [oneline update_thunk_def] + \\ ntac 4 (TOP_CASE_TAC \\ gvs []) + \\ `r.refs = t2.refs` by gvs [state_rel_def] \\ gvs [] \\ rw [] + \\ gvs [set_var_def] + \\ unabbrev_all_tac \\ gvs [] + \\ gvs [state_rel_def, lookup_insert, lookup_inter_alt, + domain_list_insert]) + >- metis_tac []) \\ Cases_on `names_opt` THEN1 (fs [compile_def] \\ Cases_on `lookup dest l2 = NONE ∧ is_pure op` \\ fs [] From c769b559f0ffe246e5262064e66975f42a4eb633 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Mon, 21 Jul 2025 14:53:59 +0300 Subject: [PATCH 021/112] fix `data_spaceProof` --- .../backend/proofs/data_spaceProofScript.sml | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/compiler/backend/proofs/data_spaceProofScript.sml b/compiler/backend/proofs/data_spaceProofScript.sml index 31b69ceeb7..ca716935b0 100644 --- a/compiler/backend/proofs/data_spaceProofScript.sml +++ b/compiler/backend/proofs/data_spaceProofScript.sml @@ -317,21 +317,19 @@ Proof domain_list_insert] \\ NO_TAC) \\ fs[do_app_def,do_space_alt] \\ IF_CASES_TAC - >- (cheat (* broke for no reason - fs[do_install_def,case_eq_thms] + >- (fs[do_install_def,case_eq_thms] \\ pairarg_tac \\ fs[] \\ pairarg_tac \\ fs[] \\ fs[case_eq_thms] \\ rveq \\ fs [] \\ rfs [] \\ fs[state_component_equality] \\ rveq - \\ qpat_abbrev_tac `v4_locals = v4.locals` + \\ qpat_x_assum `_ = s1.locals` (assume_tac o GSYM) \\ gvs [] \\ rveq \\ fs[op_space_req_def] \\ first_assum(mp_tac o MATCH_MP(REWRITE_RULE[GSYM AND_IMP_INTRO]evaluate_locals)) \\ disch_then drule \\ simp[] - \\ qpat_abbrev_tac`ll = insert n _ (inter _ _)` - \\ disch_then(qspec_then`ll`mp_tac) + \\ disch_then(qspec_then`s1.locals`mp_tac) \\ impl_tac THEN1 (UNABBREV_ALL_TAC \\ fs[] \\ fs[dataSemTheory.state_component_equality] @@ -339,9 +337,9 @@ Proof \\ fs[locals_ok_def,lookup_insert,lookup_inter_alt] \\ fs[domain_delete,domain_list_insert]) \\ strip_tac \\ simp[] - \\ drule_then (qspecl_then [ `v4.stack_max` - , `v4.safe_for_space` - , `v4.peak_heap_length`] ASSUME_TAC) + \\ drule_then (qspecl_then [ `s1.stack_max` + , `s1.safe_for_space` + , `s1.peak_heap_length`] ASSUME_TAC) evaluate_smx_safe_peak_swap \\ fs [state_fupdcanon] \\ qexists_tac`w` @@ -351,7 +349,7 @@ Proof \\ MAP_EVERY qexists_tac [`safe''`,`peak''`,`smx`] \\ fs[] \\ Cases_on`res` \\ fs[] - \\ fs[locals_ok_def]*)) + \\ fs[locals_ok_def]) \\ IF_CASES_TAC THEN1 fs [] \\ REV_FULL_SIMP_TAC std_ss [] \\ fs[consume_space_def,flush_state_def] From 5a0ec0830d69070751304903621b99694cf2b029 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Mon, 21 Jul 2025 19:54:16 +0300 Subject: [PATCH 022/112] Made AppUnit in data complete --- .../backend/proofs/bvi_to_dataProofScript.sml | 34 +++++++++++++------ .../backend/proofs/data_liveProofScript.sml | 9 +++-- compiler/backend/semantics/bviSemScript.sml | 4 +++ compiler/backend/semantics/bvlSemScript.sml | 4 +-- compiler/backend/semantics/dataSemScript.sml | 24 ++++++++++--- 5 files changed, 56 insertions(+), 19 deletions(-) diff --git a/compiler/backend/proofs/bvi_to_dataProofScript.sml b/compiler/backend/proofs/bvi_to_dataProofScript.sml index c6c8a7d801..5f24f75926 100644 --- a/compiler/backend/proofs/bvi_to_dataProofScript.sml +++ b/compiler/backend/proofs/bvi_to_dataProofScript.sml @@ -693,18 +693,32 @@ QED Theorem AppUnit_eq: evaluate (AppUnit,t) = - evaluate (Seq (Seq (Seq Skip (Assign 1 (BlockOp (Cons 0)) [] NONE)) - (Seq Skip + evaluate (Seq + (Seq + (Seq (Seq Skip (Assign 1 (IntOp (Const 0)) [] NONE)) (Seq - (Seq (Seq Skip (Assign 2 (IntOp (Const 0)) [] NONE)) - Skip) (Assign 3 (MemOp El) [0; 2] NONE)))) - (Call NONE NONE [1; 0; 3] NONE),t) + (Seq (Seq Skip (Assign 2 (IntOp (Const 1)) [] NONE)) + Skip) (Assign 3 (MemOp El) [0; 2] NONE))) + (Assign 4 (BlockOp Equal) [3; 1] + (SOME (list_to_num_set [3; 1; 0])))) + (If 4 + (Seq + (Seq (Seq Skip (Assign 5 (BlockOp (Cons 0)) [] NONE)) + (Seq Skip + (Seq + (Seq + (Seq Skip (Assign 6 (IntOp (Const 0)) [] NONE)) + Skip) (Assign 7 (MemOp El) [0; 6] NONE)))) + (Call NONE NONE [5; 0; 7] NONE)) + (Seq + (Seq (Seq Skip (Assign 9 (BlockOp (Cons 0)) [] NONE)) Skip) + (Call NONE (SOME bvl_num_stubs) [9; 0] NONE))),t) Proof - rw [AppUnit_def] + simp [AppUnit_def] \\ simp [evaluate_def, dataLangTheory.op_requires_names_def, dataLangTheory.op_space_reset_def, cut_state_opt_def, get_vars_def, - do_app_def, do_space_def, data_spaceTheory.op_space_req_def, - do_app_aux_def, set_var_def, flush_state_def, do_stack_def, + do_app_def, do_app_aux_def, do_space_def, + data_spaceTheory.op_space_req_def, backend_commonTheory.small_enough_int_def] QED @@ -1082,8 +1096,6 @@ Proof \\ strip_tac \\ gvs [] \\ Cases_on `pres` \\ gvs [] \\ gvs [data_to_bvi_v_def, SF ETA_ss] - \\ `∃ts tag w1 ws1. a = Block ts tag (w1::ws1)` by cheat \\ gvs [] - \\ `∃loc. w1 = CodePtr loc` by cheat \\ gvs [] \\ gvs [bviSemTheory.AppUnit_def, compile_def] \\ gvs [any_el_def, dataLangTheory.mk_ticks_def] \\ gvs [iAssign_def, dataLangTheory.op_requires_names_def, @@ -1100,7 +1112,7 @@ Proof \\ simp [bviSemTheory.store_thunk_def] \\ ntac 3 (TOP_CASE_TAC \\ simp []) \\ strip_tac \\ gvs [] \\ simp [update_thunk_def] - \\ `dest_thunk [a] t2'.refs = NotThunk` by ( + \\ `dest_thunk [a'] t2'.refs = NotThunk` by ( gvs [state_rel_def, oneline bviSemTheory.dest_thunk_def, oneline dest_thunk_def] \\ CASE_TAC \\ gvs [data_to_bvi_v_def] diff --git a/compiler/backend/proofs/data_liveProofScript.sml b/compiler/backend/proofs/data_liveProofScript.sml index a36cd9c5dd..21fb419384 100644 --- a/compiler/backend/proofs/data_liveProofScript.sml +++ b/compiler/backend/proofs/data_liveProofScript.sml @@ -246,9 +246,14 @@ Proof \\ last_x_assum drule \\ rw [] \\ pop_assum $ qspec_then `l2` assume_tac \\ gvs [] \\ `∀s. (AppUnit,insert 0 () LN) = compile AppUnit s` by ( - simp [AppUnit_def, compile_def, is_pure_def, list_insert_def, + rpt (pop_assum kall_tac) + \\ rw [] + \\ simp [AppUnit_def, compile_def, is_pure_def, list_insert_def, list_to_num_set_def, lookup_insert] - \\ simp [insert_compute, delete_compute, mk_BS_def]) + \\ rpt (pairarg_tac \\ simp [] \\ gvs []) + \\ gvs [AllCaseEqs(), lookup_inter_alt, lookup_delete, lookup_insert] + \\ gvs [insert_compute, delete_compute, mk_BN_def, mk_BS_def, union_def, + inter_def]) \\ Cases_on `q = SOME (Rerr (Rabort Rtype_error))` \\ gvs [] \\ qpat_x_assum `_ ⇒ _` mp_tac \\ impl_tac diff --git a/compiler/backend/semantics/bviSemScript.sml b/compiler/backend/semantics/bviSemScript.sml index 1522a14fc8..7374482a23 100644 --- a/compiler/backend/semantics/bviSemScript.sml +++ b/compiler/backend/semantics/bviSemScript.sml @@ -195,10 +195,14 @@ End Definition AppUnit_def: AppUnit = + If (Op (BlockOp Equal) + [Op (IntOp (Const 0)) []; + Op (MemOp El) [Op (IntOp (Const 1)) []; Var 0]]) (Call 0 NONE [Op (BlockOp (Cons 0)) []; Var 0; Op (MemOp El) [Op (IntOp (Const 0)) []; Var 0]] NONE) + (Call 0 (SOME num_stubs) [Op (BlockOp (Cons 0)) []; Var 0] NONE) End diff --git a/compiler/backend/semantics/bvlSemScript.sml b/compiler/backend/semantics/bvlSemScript.sml index f87acaee2a..79b126bea2 100644 --- a/compiler/backend/semantics/bvlSemScript.sml +++ b/compiler/backend/semantics/bvlSemScript.sml @@ -519,9 +519,9 @@ End Definition AppUnit_def: AppUnit = - (*If (Op (BlockOp Equal) [mk_const 0; mk_el (Var 0) (mk_const 1)])*) + If (Op (BlockOp Equal) [mk_const 0; mk_el (Var 0) (mk_const 1)]) (Call 0 NONE [mk_unit; Var 0; mk_el (Var 0) (mk_const 0)]) - (*(Call 0 (SOME 0) [mk_unit; Var 0])*) + (Call 0 (SOME 0) [mk_unit; Var 0]) End (* The evaluation is defined as a clocked functional version of diff --git a/compiler/backend/semantics/dataSemScript.sml b/compiler/backend/semantics/dataSemScript.sml index 9fc46d1995..3715a63bd9 100644 --- a/compiler/backend/semantics/dataSemScript.sml +++ b/compiler/backend/semantics/dataSemScript.sml @@ -1232,10 +1232,26 @@ End Definition AppUnit_def: AppUnit = - Seq (Assign 1 (BlockOp (Cons 0)) [] NONE) $ - Seq (Assign 2 (IntOp (Const 0)) [] NONE) $ - Seq (Assign 3 (MemOp El) [0; 2] NONE) - (Call NONE NONE [1; 0; 3] NONE) + Seq + (Seq + (Seq + (Assign 1 (IntOp (Const 0)) [] NONE) + (Seq + (Assign 2 (IntOp (Const 1)) [] NONE) + (Assign 3 (MemOp El) [0; 2] NONE))) + (Assign 4 (BlockOp Equal) [3; 1] + (SOME (list_to_num_set [3; 1; 0])))) + (If 4 + (Seq + (Seq + (Assign 5 (BlockOp (Cons 0)) [] NONE) + (Seq + (Assign 6 (IntOp (Const 0)) [] NONE) + (Assign 7 (MemOp El) [0; 6] NONE))) + (Call NONE NONE [5; 0; 7] NONE)) + (Seq + (Assign 9 (BlockOp (Cons 0)) [] NONE) + (Call NONE (SOME bvl_num_stubs) [9; 0] NONE))) End Definition evaluate_def: From 01dfd5bcace214397007f15a07401f4863d51aa4 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Wed, 23 Jul 2025 13:45:28 +0300 Subject: [PATCH 023/112] Fixes after master merge --- .../backend/proofs/bvi_tailrecProofScript.sml | 2 - .../backend/proofs/bvi_to_dataProofScript.sml | 55 ++++++++----------- .../backend/proofs/bvl_to_bviProofScript.sml | 17 +----- .../backend/proofs/clos_interpProofScript.sml | 4 +- .../backend/proofs/clos_to_bvlProofScript.sml | 34 ++---------- .../backend/proofs/data_liveProofScript.sml | 2 +- .../backend/semantics/dataPropsScript.sml | 11 ++-- 7 files changed, 39 insertions(+), 86 deletions(-) diff --git a/compiler/backend/proofs/bvi_tailrecProofScript.sml b/compiler/backend/proofs/bvi_tailrecProofScript.sml index 4413e67ce2..16c70c48f8 100644 --- a/compiler/backend/proofs/bvi_tailrecProofScript.sml +++ b/compiler/backend/proofs/bvi_tailrecProofScript.sml @@ -1637,8 +1637,6 @@ Proof >- ( gvs [] \\ last_assum $ qspecl_then [`xs`, `s`] mp_tac \\ gvs[] - \\ impl_tac - >- simp [bviTheory.exp_size_def] \\ `env_rel ty F acc env1 env2` by fs [env_rel_def] \\ gvs [] \\ rpt (disch_then drule) \\ rw [] \\ gvs [AllCaseEqs(), PULL_EXISTS] diff --git a/compiler/backend/proofs/bvi_to_dataProofScript.sml b/compiler/backend/proofs/bvi_to_dataProofScript.sml index 0cded5024c..4e769e0e80 100644 --- a/compiler/backend/proofs/bvi_to_dataProofScript.sml +++ b/compiler/backend/proofs/bvi_to_dataProofScript.sml @@ -601,10 +601,8 @@ Proof >- (rw [data_to_bvi_ref_def] \\ gvs [refs_rel_LEAST_eq, lookup_map, map_replicate]) >~ [`ThunkOp (UpdateThunk t)`] - >- (Cases_on `z` \\ gvs [data_to_bvi_ref_def, data_to_bvi_v_def] - \\ gvs [data_to_bvi_v_def, Unit_def, bvlSemTheory.Unit_def] - \\ rw [data_to_bvi_ref_def] - \\ gvs [refs_rel_LEAST_eq, lookup_map, lookup_insert, LUPDATE_MAP]) + >- (rw [data_to_bvi_ref_def] + \\ gvs [refs_rel_LEAST_eq, lookup_map, map_replicate]) QED Theorem state_rel_peak_safe: @@ -692,7 +690,7 @@ Proof simp [AppUnit_def] \\ simp [evaluate_def, dataLangTheory.op_requires_names_def, dataLangTheory.op_space_reset_def, cut_state_opt_def, get_vars_def, - do_app_def, do_app_aux_def, do_space_def, + do_app_def, do_int_app_def, do_app_aux_def, do_space_def, data_spaceTheory.op_space_req_def, backend_commonTheory.small_enough_int_def] QED @@ -1015,24 +1013,23 @@ Proof \\ IMP_RES_TAC get_vars_inter \\ IMP_RES_TAC get_vars_reverse \\ rveq \\ fs []) + \\ gvs [] \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs [] >- ( gvs [evaluate_push_Seq] \\ gvs [iAssign_def, dataLangTheory.op_requires_names_def, dataLangTheory.op_space_reset_def] \\ gvs [evaluate_def, cut_state_opt_def, cut_state_def, cut_env_def] - \\ gvs [oneline bviSemTheory.dest_thunk_def, AllCaseEqs(), PULL_EXISTS] - \\ Cases_on `x0` \\ gvs [data_to_bvi_v_def] + \\ gvs [oneline bviSemTheory.dest_thunk_def, dest_thunk_def, AllCaseEqs()] + \\ pairarg_tac \\ gvs [] >- ( - `lookup n' (map data_to_bvi_ref t2.refs) = + `lookup ptr (map data_to_bvi_ref t2.refs) = SOME (Thunk Evaluated v)`by gvs [state_rel_def] - \\ gvs [lookup_map] - \\ Cases_on `z` - \\ gvs [data_to_bvi_ref_def, dest_thunk_def, set_var_def] + \\ gvs [lookup_map, set_var_def] \\ Cases_on `tail` \\ gvs [evaluate_def] >- gvs [get_var_def, flush_state_def, data_to_bvi_result_def, state_rel_def] \\ rw [] - >- gvs [state_rel_def] + >- gvs [state_rel_def, set_var_def] >- (unabbrev_all_tac \\ gvs [lookup_insert, lookup_inter]) >- ( unabbrev_all_tac @@ -1055,23 +1052,19 @@ Proof >- gvs [var_corr_def, get_var_def, get_vars_def, lookup_map, state_rel_def, data_to_bvi_ref_def]) >- ( - `lookup n' (map data_to_bvi_ref t2.refs) = + `lookup ptr (map data_to_bvi_ref t2.refs) = SOME (Thunk NotEvaluated v)` by gvs [state_rel_def] \\ gvs [lookup_map] - \\ Cases_on `z` - \\ gvs [data_to_bvi_ref_def, dest_thunk_def, set_var_def] \\ `r.clock = t2.clock` by gvs [state_rel_def] \\ gvs [flush_state_def, data_to_bvi_result_def, state_rel_def]) >- ( - `lookup n' (map data_to_bvi_ref t2.refs) = + `lookup ptr (map data_to_bvi_ref t2.refs) = SOME (Thunk NotEvaluated v)`by gvs [state_rel_def] \\ gvs [lookup_map] - \\ Cases_on `z` - \\ gvs [data_to_bvi_ref_def, dest_thunk_def, set_var_def] \\ `r.clock = t2.clock` by gvs [state_rel_def] \\ gvs [PULL_EXISTS] \\ `state_rel (dec_clock 1 r) (t2 with <| - locals := insert 0 a LN; + locals := insert 0 w' LN; clock := t2.clock - 1 |>)` by gvs [bviSemTheory.dec_clock_def, dec_clock_def, state_rel_def] \\ last_x_assum $ drule_at (Pat `state_rel _ _`) \\ gvs [] @@ -1092,13 +1085,12 @@ Proof >- (Cases_on `e` \\ gvs [data_to_bvi_result_def]) \\ imp_res_tac evaluate_locals_LN \\ gvs [] \\ qpat_x_assum `evaluate _ = (SOME x,_)` kall_tac - \\ gvs [data_to_bvi_result_def] \\ qpat_x_assum `update_thunk _ _ _ = SOME _` mp_tac \\ simp [bviSemTheory.update_thunk_def] \\ TOP_CASE_TAC \\ simp [bviSemTheory.store_thunk_def] \\ ntac 3 (TOP_CASE_TAC \\ simp []) \\ strip_tac \\ gvs [] - \\ simp [update_thunk_def] - \\ `dest_thunk [a'] t2'.refs = NotThunk` by ( + \\ gvs [update_thunk_def] + \\ `dest_thunk [a] t2'.refs = NotThunk` by ( gvs [state_rel_def, oneline bviSemTheory.dest_thunk_def, oneline dest_thunk_def] \\ CASE_TAC \\ gvs [data_to_bvi_v_def] @@ -1106,18 +1098,19 @@ Proof \\ gvs [lookup_map] \\ ntac 2 (CASE_TAC \\ gvs []) \\ gvs [data_to_bvi_ref_def]) \\ gvs [] - \\ simp [store_thunk_def] + \\ gvs [store_thunk_def] \\ `∀n. FLOOKUP s''.refs n = lookup n (map data_to_bvi_ref t2'.refs)` by gvs [state_rel_def] \\ gvs [] - \\ pop_assum $ qspec_then `n'` assume_tac \\ gvs [] + \\ pop_assum $ qspec_then `ptr` assume_tac \\ gvs [] \\ gvs [lookup_map] - \\ Cases_on `z` \\ gvs [data_to_bvi_ref_def] \\ Cases_on `tail` \\ gvs [evaluate_def] >- ( - gvs [get_var_def, state_rel_def, flush_state_def, lookup_map, - lookup_insert, FLOOKUP_UPDATE, data_to_bvi_result_def] + gvs [get_var_def, set_var_def, state_rel_def, flush_state_def, + lookup_map, lookup_insert, FLOOKUP_UPDATE, + data_to_bvi_result_def] \\ rw [] \\ gvs [data_to_bvi_ref_def]) - \\ gvs [lookup_insert, map_insert, var_corr_def, get_var_def] + \\ gvs [lookup_insert, map_insert, var_corr_def, get_var_def, + set_var_def] \\ conj_tac >- ( gvs [state_rel_def, lookup_map, lookup_insert] @@ -1159,15 +1152,13 @@ Proof \\ gvs [jump_exc_def] \\ rpt (CASE_TAC \\ gvs [])) >- ( - `lookup n' (map data_to_bvi_ref t2.refs) = + `lookup ptr (map data_to_bvi_ref t2.refs) = SOME (Thunk NotEvaluated v)` by gvs [state_rel_def] \\ gvs [lookup_map] - \\ Cases_on `z` - \\ gvs [data_to_bvi_ref_def, dest_thunk_def, set_var_def] \\ `r.clock = t2.clock` by gvs [state_rel_def] \\ gvs [PULL_EXISTS] \\ `state_rel (dec_clock 1 r) (t2 with <| - locals := insert 0 a LN; + locals := insert 0 w' LN; clock := t2.clock - 1 |>)` by gvs [bviSemTheory.dec_clock_def, dec_clock_def, state_rel_def] \\ last_x_assum $ drule_at (Pat `state_rel _ _`) \\ gvs [] diff --git a/compiler/backend/proofs/bvl_to_bviProofScript.sml b/compiler/backend/proofs/bvl_to_bviProofScript.sml index 26691a248b..ad8cac11b0 100644 --- a/compiler/backend/proofs/bvl_to_bviProofScript.sml +++ b/compiler/backend/proofs/bvl_to_bviProofScript.sml @@ -315,7 +315,7 @@ Proof QED fun cases_on_op q = Cases_on q >| - map (MAP_EVERY Cases_on) [[], [], [], [], [`b`], [`g`], [`m`], []]; + map (MAP_EVERY Cases_on) [[], [], [], [], [`b`], [`g`], [`m`], [], [`t`]]; Theorem do_app_ok_lemma[local]: state_ok r /\ EVERY (bv_ok r.refs) a /\ @@ -379,21 +379,6 @@ Proof \\ TRY (SRW_TAC [] [] \\ full_simp_tac(srw_ss())[bv_ok_def,EVERY_EL] \\ NO_TAC) \\ TRY (SRW_TAC [] [] \\ full_simp_tac(srw_ss())[bv_ok_def,EVERY_MEM] \\ NO_TAC) \\ STRIP_TAC \\ full_simp_tac(srw_ss())[LET_THM] \\ rpt BasicProvers.VAR_EQ_TAC - >- (rename1 `FFI` >> - full_simp_tac(srw_ss())[state_ok_def] \\ srw_tac[][] >- - (full_simp_tac(srw_ss())[EVERY_MEM] \\ REPEAT STRIP_TAC - \\ BasicProvers.EVERY_CASE_TAC - \\ RES_TAC \\ full_simp_tac(srw_ss())[] - \\ Q.ISPEC_THEN`r.refs`match_mp_tac bv_ok_SUBSET_IMP - \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[SUBSET_DEF,FLOOKUP_DEF]) - \\ simp[FLOOKUP_UPDATE] >> srw_tac[][] >> - BasicProvers.CASE_TAC >> - BasicProvers.CASE_TAC >> - first_x_assum(qspec_then`k`mp_tac) >> srw_tac[][] >> - full_simp_tac(srw_ss())[EVERY_MEM] \\ REPEAT STRIP_TAC - \\ RES_TAC \\ full_simp_tac(srw_ss())[] - \\ Q.ISPEC_THEN`r.refs`match_mp_tac bv_ok_SUBSET_IMP - \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[SUBSET_DEF,FLOOKUP_DEF]) >- (rename1 `FFI` >> full_simp_tac(srw_ss())[state_ok_def] \\ srw_tac[][] >- (full_simp_tac(srw_ss())[EVERY_MEM] \\ REPEAT STRIP_TAC diff --git a/compiler/backend/proofs/clos_interpProofScript.sml b/compiler/backend/proofs/clos_interpProofScript.sml index 7bb8279282..d7bc7b76c4 100644 --- a/compiler/backend/proofs/clos_interpProofScript.sml +++ b/compiler/backend/proofs/clos_interpProofScript.sml @@ -993,7 +993,7 @@ Proof \\ gvs [Abbr‘vr’] >- (Cases_on ‘err’ \\ gvs []) \\ fs [state_rel_def,state_rel_1_def] \\ drule_then irule do_app_oHD_globals \\ fs []) - >~ [`Install`] >- ( + >~ [`do_install`] >- ( rename [‘state_rel s3 t3’] \\ qpat_x_assum ‘do_install _ _ = _’ mp_tac \\ simp [Once do_install_def] @@ -1045,7 +1045,7 @@ Proof \\ fs [do_install_def,pure_co_def,shift_seq_def,pure_cc_def,pure_co_def,PULL_EXISTS] \\ gvs [FUPDATE_LIST] \\ gvs [AllCaseEqs()]) - >~ [`ThunkOp ForceThunk`] >- ( + >~ [`dest_thunk`] >- ( gvs [AllCaseEqs()] \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] \\ qrefine `ck + ck'` \\ gvs [] diff --git a/compiler/backend/proofs/clos_to_bvlProofScript.sml b/compiler/backend/proofs/clos_to_bvlProofScript.sml index c998895c28..0f2984deec 100644 --- a/compiler/backend/proofs/clos_to_bvlProofScript.sml +++ b/compiler/backend/proofs/clos_to_bvlProofScript.sml @@ -1537,7 +1537,7 @@ Proof QED fun cases_on_op q = Cases_on q >| - map (MAP_EVERY Cases_on) [[], [], [], [], [`b`], [`g`], [`m`], []]; + map (MAP_EVERY Cases_on) [[], [], [], [], [`b`], [`g`], [`m`], [], [`t`]]; Theorem do_app[local]: (do_app op xs s1 = Rval (v,s2)) /\ @@ -5052,10 +5052,12 @@ Proof \\ reverse STRIP_TAC THEN1 (UNABBREV_ALL_TAC \\ full_simp_tac(srw_ss())[] \\ MATCH_MP_TAC (env_rel_NEW_REF |> GEN_ALL) \\ full_simp_tac(srw_ss())[]) - \\ srw_tac[][LIST_REL_EL_EQN, LENGTH_GENLIST, LENGTH_MAP2, el_map2] + \\ srw_tac[][LIST_REL_EL_EQN, LENGTH_GENLIST, LENGTH_MAP2, ADD1] + \\ DEP_REWRITE_TAC [el_map2] + \\ conj_tac >- gvs [] \\ srw_tac[][v_rel_cases, cl_rel_cases] \\ full_simp_tac(srw_ss())[] - \\ srw_tac [boolSimps.DNF_ss] [] + \\ simp_tac std_ss [SF DNF_ss] \\ disj2_tac \\ qexists_tac `ys` \\ qabbrev_tac `exps = ll++[x'']` @@ -5072,32 +5074,6 @@ Proof (Q.PAT_X_ASSUM `LIST_REL (v_rel _ f1 t1.refs t1.code) x' ys` MP_TAC \\ MATCH_MP_TAC listTheory.LIST_REL_mono \\ IMP_RES_TAC v_rel_NEW_REF \\ full_simp_tac(srw_ss())[]) - \\ MATCH_MP_TAC env_rel_APPEND - \\ reverse STRIP_TAC THEN1 - (UNABBREV_ALL_TAC \\ full_simp_tac(srw_ss())[] - \\ MATCH_MP_TAC (env_rel_NEW_REF |> GEN_ALL) \\ full_simp_tac(srw_ss())[]) - \\ srw_tac[][LIST_REL_EL_EQN, LENGTH_GENLIST, LENGTH_MAP2, ADD1] - \\ DEP_REWRITE_TAC [el_map2] - \\ conj_tac >- gvs [] - \\ srw_tac[][v_rel_cases, cl_rel_cases] - \\ full_simp_tac(srw_ss())[] - \\ simp_tac std_ss [SF DNF_ss] - \\ disj2_tac - \\ qexists_tac `ys` - \\ qabbrev_tac `exps = ll++[x'']` - \\ `LENGTH ll + 1 = LENGTH exps` by full_simp_tac(srw_ss())[Abbr `exps`] - \\ Q.EXISTS_TAC `ZIP (exps,GENLIST (\i.x+num_stubs s.max_app+2*i) (LENGTH exps))` - \\ full_simp_tac(srw_ss())[LENGTH_ZIP, EL_MAP, LENGTH_MAP, EL_ZIP, MAP_ZIP] - \\ `?num e. EL n exps = (num, e)` by metis_tac [pair_CASES] - \\ `1 < LENGTH exps` by (full_simp_tac(srw_ss())[] \\ DECIDE_TAC) - \\ full_simp_tac(srw_ss())[Abbr `t1refs`,FLOOKUP_UPDATE] - \\ `MAP FST ll ++ [FST x''] = MAP FST exps` by srw_tac[][Abbr `exps`] - \\ simp [EL_MAP,EL_ZIP] - \\ srw_tac[][] - THEN1 - (Q.PAT_X_ASSUM `LIST_REL (v_rel _ f1 t1.refs t1.code) x' ys` MP_TAC - \\ MATCH_MP_TAC listTheory.LIST_REL_mono - \\ METIS_TAC [v_rel_NEW_REF]) THEN1 (full_simp_tac(srw_ss())[state_rel_def, SUBSET_DEF] >> metis_tac []) THEN1 diff --git a/compiler/backend/proofs/data_liveProofScript.sml b/compiler/backend/proofs/data_liveProofScript.sml index 4cae0e2924..b24f6e8a4d 100644 --- a/compiler/backend/proofs/data_liveProofScript.sml +++ b/compiler/backend/proofs/data_liveProofScript.sml @@ -49,7 +49,7 @@ Proof QED fun cases_on_op q = Cases_on q >| - map (MAP_EVERY Cases_on) [[], [], [], [], [`b`], [`g`], [`m`], []]; + map (MAP_EVERY Cases_on) [[], [], [], [], [`b`], [`g`], [`m`], [], [`t`]]; Triviality state_rel_IMP_do_app_aux: (do_app_aux op args s1 = Rval (v,s2)) /\ diff --git a/compiler/backend/semantics/dataPropsScript.sml b/compiler/backend/semantics/dataPropsScript.sml index aeeaaef2e5..635b6586ef 100644 --- a/compiler/backend/semantics/dataPropsScript.sml +++ b/compiler/backend/semantics/dataPropsScript.sml @@ -297,7 +297,7 @@ Proof semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq, pair_case_eq,consume_space_def,check_lim_def] \\ rveq \\ full_simp_tac(srw_ss()) [] \\ rw []) - \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) + \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_` \\ gvs []) QED (*fs[] is slower than full_simp_tac(srw_ss())[]*) @@ -315,7 +315,7 @@ Proof semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq, pair_case_eq,consume_space_def,check_lim_def,UNCURRY_EQ] \\ rveq \\ fs [] \\ rw []) - \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) \\ gvs [] + \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_` \\ gvs []) QED (*fs[] is slower than full_simp_tac(srw_ss())[]*) @@ -455,6 +455,7 @@ val do_app_swap_tac = , consume_space_def , stack_consumed_def , size_of_heap_with_safe + , MAX_DEF , check_lim_def] \\ TRY (full_simp_tac(srw_ss())[LET_DEF,UNCURRY_EQ,list_case_eq,option_case_eq,v_case_eq,bool_case_eq,bvlSemTheory.ref_case_eq , ffiTheory.ffi_result_case_eq,ffiTheory.oracle_result_case_eq, state_component_equality @@ -462,7 +463,9 @@ val do_app_swap_tac = , limits_component_equality,stack_consumed_def] \\ full_simp_tac(srw_ss()) [data_spaceTheory.op_space_req_def,stack_consumed_def] \\ rev_full_simp_tac(srw_ss())[data_spaceTheory.op_space_req_def] - \\ simp [Once CONJ_COMM] \\ NO_TAC)); + \\ simp [Once CONJ_COMM] \\ NO_TAC) + \\ rpt(PURE_TOP_CASE_TAC \\ fs[] \\ rveq) \\ fs[state_component_equality,stack_consumed_def] + \\ gvs [AllCaseEqs()]); Theorem do_app_aux_safe_peak_swap: @@ -674,7 +677,7 @@ Proof \\ rveq \\ fs [] \\ every_case_tac \\ fs [] \\ rveq \\ fs [] \\ gvs [AllCaseEqs(), PULL_EXISTS] - >>~- ([`evaluate (AppUnit,_) = (SOME _,_)`, + >>~- ([`evaluate (AppUnit,_) = _`, `dest_thunk _ _ = IsThunk NotEvaluated _`], TRY ( first_x_assum $ qspecl_then [`T`, `smx`, `safe`, `peak`] assume_tac From 841add6ea6b28e7b3c2714b65badbbda0842b2d1 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Wed, 23 Jul 2025 15:07:12 +0300 Subject: [PATCH 024/112] Fixes after master merge --- .../backend/proofs/clos_to_bvlProofScript.sml | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/compiler/backend/proofs/clos_to_bvlProofScript.sml b/compiler/backend/proofs/clos_to_bvlProofScript.sml index e17ded584f..4d9812b8f5 100644 --- a/compiler/backend/proofs/clos_to_bvlProofScript.sml +++ b/compiler/backend/proofs/clos_to_bvlProofScript.sml @@ -4040,7 +4040,8 @@ Proof \\ qrefinel [`_`, `f2'`, `v''`, `t2'`] \\ rw [GSYM PULL_EXISTS] >- ( gvs [AppUnit_def] - \\ gvs [evaluate_def, clos_tag_shift_def, mk_cl_call_def, do_app_def] + \\ gvs [evaluate_def, clos_tag_shift_def, mk_cl_call_def, do_app_def, + do_int_app_def] \\ Cases_on `r2` \\ gvs [AllCaseEqs(), PULL_EXISTS, mk_unit_def, evaluate_def, generic_app_fn_location_def] @@ -4108,12 +4109,12 @@ Proof \\ qrefinel [`_`, `Rerr e'`, `t2'`] \\ rw [GSYM PULL_EXISTS] >- ( gvs [AppUnit_def] - \\ gvs [evaluate_def, clos_tag_shift_def, mk_cl_call_def, do_app_def] - \\ rpt ( - CASE_TAC - \\ gvs [mk_unit_def, evaluate_def, generic_app_fn_location_def]) - \\ gvs [AllCaseEqs()] - \\ qexists `ck'` \\ gvs []) + \\ simp [do_app_def, do_int_app_def, mk_unit_def, evaluate_def] + \\ qexists `ck'` \\ gvs [] + \\ gvs [evaluate_def, mk_cl_call_def, generic_app_fn_location_def, + do_app_def, clos_tag_shift_def, find_code_def] + \\ rpt (PURE_CASE_TAC \\ gvs []) + \\ gvs [AllCaseEqs()]) \\ imp_res_tac SUBMAP_TRANS) >- ( first_x_assum drule_all \\ rw [] \\ gvs [] From 728e6076a998000866de8f5819ee7c940878c95a Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Wed, 23 Jul 2025 20:23:44 +0300 Subject: [PATCH 025/112] More compact AppUnit definitions --- compiler/backend/bviScript.sml | 4 +++ compiler/backend/bvlScript.sml | 4 +++ compiler/backend/clos_to_bvlScript.sml | 2 -- .../backend/proofs/bvi_to_dataProofScript.sml | 31 ++++++++----------- .../backend/proofs/bvl_inlineProofScript.sml | 4 +-- .../backend/proofs/bvl_to_bviProofScript.sml | 4 +-- .../backend/proofs/clos_to_bvlProofScript.sml | 6 ++-- compiler/backend/semantics/bviSemScript.sml | 11 ++----- compiler/backend/semantics/bvlSemScript.sml | 8 ++--- compiler/backend/semantics/dataSemScript.sml | 23 +++++--------- 10 files changed, 40 insertions(+), 57 deletions(-) diff --git a/compiler/backend/bviScript.sml b/compiler/backend/bviScript.sml index 8ef341a426..2d56399a2e 100644 --- a/compiler/backend/bviScript.sml +++ b/compiler/backend/bviScript.sml @@ -48,4 +48,8 @@ Datatype: | Op op (exp list) End +Overload mk_unit = “bvi$Op (BlockOp (Cons 0)) []” + +Overload mk_elem_at = “λb i. bvi$Op (BlockOp (ElemAt i)) [b]” + val _ = export_theory(); diff --git a/compiler/backend/bvlScript.sml b/compiler/backend/bvlScript.sml index 925cb43025..eba4de98fe 100644 --- a/compiler/backend/bvlScript.sml +++ b/compiler/backend/bvlScript.sml @@ -45,4 +45,8 @@ Definition mk_tick_def: mk_tick n e = FUNPOW Tick n e : bvl$exp End +Overload mk_unit = “bvl$Op (BlockOp (Cons 0)) []” + +Overload mk_elem_at = “λb i. bvl$Op (BlockOp (ElemAt i)) [b]”; + val _ = export_theory(); diff --git a/compiler/backend/clos_to_bvlScript.sml b/compiler/backend/clos_to_bvlScript.sml index b1e62bcb0a..1c7cde1cf1 100644 --- a/compiler/backend/clos_to_bvlScript.sml +++ b/compiler/backend/clos_to_bvlScript.sml @@ -177,8 +177,6 @@ Definition mk_el_def[simp]: mk_el b i : bvl$exp = Op (MemOp El) [i; b] End -Overload mk_elem_at[local] = “λb i. bvl$Op (BlockOp (ElemAt i)) [b]”; - Definition free_let_def: free_let cl n = (GENLIST (\n. mk_elem_at cl (n+2)) n) End diff --git a/compiler/backend/proofs/bvi_to_dataProofScript.sml b/compiler/backend/proofs/bvi_to_dataProofScript.sml index 4e769e0e80..a15db9aa1a 100644 --- a/compiler/backend/proofs/bvi_to_dataProofScript.sml +++ b/compiler/backend/proofs/bvi_to_dataProofScript.sml @@ -667,25 +667,20 @@ QED Theorem AppUnit_eq: evaluate (AppUnit,t) = evaluate (Seq - (Seq - (Seq (Seq Skip (Assign 1 (IntOp (Const 0)) [] NONE)) + (Seq + (Seq Skip (Assign 1 (BlockOp (ElemAt 1)) [0] NONE)) + (Assign 2 (BlockOp (EqualConst (Int 0))) [1] NONE)) + (If 2 + (Seq (Seq - (Seq (Seq Skip (Assign 2 (IntOp (Const 1)) [] NONE)) - Skip) (Assign 3 (MemOp El) [0; 2] NONE))) - (Assign 4 (BlockOp Equal) [3; 1] - (SOME (list_to_num_set [3; 1; 0])))) - (If 4 - (Seq - (Seq (Seq Skip (Assign 5 (BlockOp (Cons 0)) [] NONE)) - (Seq Skip - (Seq - (Seq - (Seq Skip (Assign 6 (IntOp (Const 0)) [] NONE)) - Skip) (Assign 7 (MemOp El) [0; 6] NONE)))) - (Call NONE NONE [5; 0; 7] NONE)) - (Seq - (Seq (Seq Skip (Assign 9 (BlockOp (Cons 0)) [] NONE)) Skip) - (Call NONE (SOME bvl_num_stubs) [9; 0] NONE))),t) + (Seq Skip (Assign 3 (BlockOp (Cons 0)) [] NONE)) + (Seq + Skip + (Seq Skip (Assign 4 (BlockOp (ElemAt 0)) [0] NONE)))) + (Call NONE NONE [3; 0; 4] NONE)) + (Seq + (Seq (Seq Skip (Assign 6 (BlockOp (Cons 0)) [] NONE)) Skip) + (Call NONE (SOME bvl_num_stubs) [6; 0] NONE))),t) Proof simp [AppUnit_def] \\ simp [evaluate_def, dataLangTheory.op_requires_names_def, diff --git a/compiler/backend/proofs/bvl_inlineProofScript.sml b/compiler/backend/proofs/bvl_inlineProofScript.sml index 2fa54e27f1..2ce362485b 100644 --- a/compiler/backend/proofs/bvl_inlineProofScript.sml +++ b/compiler/backend/proofs/bvl_inlineProofScript.sml @@ -235,7 +235,7 @@ Proof \\ gvs [PULL_EXISTS] \\ `evaluate (remove_ticks [AppUnit],[v],dec_clock 1 r) = evaluate ([AppUnit],[v],dec_clock 1 r)` - by gvs [AppUnit_def, mk_unit_def, remove_ticks_def] + by gvs [AppUnit_def, remove_ticks_def] \\ gvs [] \\ `(dec_clock 1 r).clock < s.clock` by ( imp_res_tac evaluate_clock \\ gvs [dec_clock_def]) @@ -1604,7 +1604,7 @@ Proof \\ `s'.clock = t2.clock` by gvs [let_state_rel_def] \\ gvs [] \\ `let_state_rel q4 l4 (dec_clock 1 s') (dec_clock 1 t2)` by gvs [let_state_rel_def, dec_clock_def] - \\ last_x_assum drule \\ rw [AppUnit_def, let_op_def, mk_unit_def] + \\ last_x_assum drule \\ rw [AppUnit_def, let_op_def] \\ gvs [] \\ gvs [let_state_rel_def])) \\ fs [case_eq_thms] \\ rveq \\ fs [] diff --git a/compiler/backend/proofs/bvl_to_bviProofScript.sml b/compiler/backend/proofs/bvl_to_bviProofScript.sml index ad8cac11b0..6284d328eb 100644 --- a/compiler/backend/proofs/bvl_to_bviProofScript.sml +++ b/compiler/backend/proofs/bvl_to_bviProofScript.sml @@ -2310,7 +2310,7 @@ Proof gvs [state_rel_def, bvlSemTheory.dec_clock_def, dec_clock_def] \\ gvs [] \\ last_x_assum $ drule_at (Pat `state_rel _ _ _`) \\ simp [bvlSemTheory.AppUnit_def, compile_exps_def, compile_op_def, - compile_int_def, bvlSemTheory.mk_unit_def] + compile_int_def] \\ impl_tac >- ( rw [handle_ok_def, aux_code_installed_def] @@ -2386,7 +2386,7 @@ Proof gvs [state_rel_def, bvlSemTheory.dec_clock_def, dec_clock_def] \\ gvs [] \\ last_x_assum $ drule_at (Pat `state_rel _ _ _`) \\ simp [bvlSemTheory.AppUnit_def, compile_exps_def, compile_op_def, - compile_int_def, bvlSemTheory.mk_unit_def] + compile_int_def] \\ impl_tac >- ( rw [handle_ok_def, aux_code_installed_def] diff --git a/compiler/backend/proofs/clos_to_bvlProofScript.sml b/compiler/backend/proofs/clos_to_bvlProofScript.sml index 4d9812b8f5..89694db594 100644 --- a/compiler/backend/proofs/clos_to_bvlProofScript.sml +++ b/compiler/backend/proofs/clos_to_bvlProofScript.sml @@ -39,8 +39,6 @@ val _ = temp_bring_to_front_overload"evaluate"{Name="evaluate",Thy="bvlSem"}; val _ = temp_bring_to_front_overload"num_stubs"{Name="num_stubs",Thy="clos_to_bvl"}; val _ = temp_bring_to_front_overload"compile_exps"{Name="compile_exps",Thy="clos_to_bvl"}; -Overload mk_elem_at[local] = “λb i. bvl$Op (BlockOp (ElemAt i)) [b]”; - (* TODO: move? *) val EVERY2_GENLIST = LIST_REL_GENLIST |> EQ_IMP_RULE |> snd |> Q.GEN`l` @@ -4043,7 +4041,7 @@ Proof \\ gvs [evaluate_def, clos_tag_shift_def, mk_cl_call_def, do_app_def, do_int_app_def] \\ Cases_on `r2` - \\ gvs [AllCaseEqs(), PULL_EXISTS, mk_unit_def, evaluate_def, + \\ gvs [AllCaseEqs(), PULL_EXISTS, evaluate_def, generic_app_fn_location_def] \\ goal_assum drule \\ gvs []) \\ gvs [oneline closSemTheory.update_thunk_def, oneline update_thunk_def, @@ -4109,7 +4107,7 @@ Proof \\ qrefinel [`_`, `Rerr e'`, `t2'`] \\ rw [GSYM PULL_EXISTS] >- ( gvs [AppUnit_def] - \\ simp [do_app_def, do_int_app_def, mk_unit_def, evaluate_def] + \\ simp [do_app_def, do_int_app_def, evaluate_def] \\ qexists `ck'` \\ gvs [] \\ gvs [evaluate_def, mk_cl_call_def, generic_app_fn_location_def, do_app_def, clos_tag_shift_def, find_code_def] diff --git a/compiler/backend/semantics/bviSemScript.sml b/compiler/backend/semantics/bviSemScript.sml index 5b8c494036..a2620fe1f6 100644 --- a/compiler/backend/semantics/bviSemScript.sml +++ b/compiler/backend/semantics/bviSemScript.sml @@ -195,14 +195,9 @@ End Definition AppUnit_def: AppUnit = - If (Op (BlockOp Equal) - [Op (IntOp (Const 0)) []; - Op (MemOp El) [Op (IntOp (Const 1)) []; Var 0]]) - (Call 0 NONE - [Op (BlockOp (Cons 0)) []; Var 0; - Op (MemOp El) [Op (IntOp (Const 0)) []; Var 0]] - NONE) - (Call 0 (SOME num_stubs) [Op (BlockOp (Cons 0)) []; Var 0] NONE) + If (Op (BlockOp (EqualConst (Int 0))) [mk_elem_at (Var 0) 1]) + (Call 0 NONE [mk_unit; Var 0; mk_elem_at (Var 0) 0] NONE) + (Call 0 (SOME num_stubs) [mk_unit; Var 0] NONE) End diff --git a/compiler/backend/semantics/bvlSemScript.sml b/compiler/backend/semantics/bvlSemScript.sml index aca4ed9a97..1beadf2f71 100644 --- a/compiler/backend/semantics/bvlSemScript.sml +++ b/compiler/backend/semantics/bvlSemScript.sml @@ -528,14 +528,10 @@ Definition update_thunk_def: update_thunk _ _ _ = NONE End -Definition mk_unit_def: - mk_unit = bvl$Op (BlockOp (Cons 0)) [] -End - Definition AppUnit_def: AppUnit = - If (Op (BlockOp Equal) [mk_const 0; mk_el (Var 0) (mk_const 1)]) - (Call 0 NONE [mk_unit; Var 0; mk_el (Var 0) (mk_const 0)]) + If (Op (BlockOp (EqualConst (Int 0))) [mk_elem_at (Var 0) 1]) + (Call 0 NONE [mk_unit; Var 0; mk_elem_at (Var 0) 0]) (Call 0 (SOME 0) [mk_unit; Var 0]) End diff --git a/compiler/backend/semantics/dataSemScript.sml b/compiler/backend/semantics/dataSemScript.sml index cca8e78bfb..8ea3e5e836 100644 --- a/compiler/backend/semantics/dataSemScript.sml +++ b/compiler/backend/semantics/dataSemScript.sml @@ -1243,24 +1243,17 @@ Definition AppUnit_def: AppUnit = Seq (Seq + (Assign 1 (BlockOp (ElemAt 1)) [0] NONE) + (Assign 2 (BlockOp (EqualConst (Int 0))) [1] NONE)) + (If 2 (Seq - (Assign 1 (IntOp (Const 0)) [] NONE) (Seq - (Assign 2 (IntOp (Const 1)) [] NONE) - (Assign 3 (MemOp El) [0; 2] NONE))) - (Assign 4 (BlockOp Equal) [3; 1] - (SOME (list_to_num_set [3; 1; 0])))) - (If 4 + (Assign 3 (BlockOp (Cons 0)) [] NONE) + (Assign 4 (BlockOp (ElemAt 0)) [0] NONE)) + (Call NONE NONE [3; 0; 4] NONE)) (Seq - (Seq - (Assign 5 (BlockOp (Cons 0)) [] NONE) - (Seq - (Assign 6 (IntOp (Const 0)) [] NONE) - (Assign 7 (MemOp El) [0; 6] NONE))) - (Call NONE NONE [5; 0; 7] NONE)) - (Seq - (Assign 9 (BlockOp (Cons 0)) [] NONE) - (Call NONE (SOME bvl_num_stubs) [9; 0] NONE))) + (Assign 6 (BlockOp (Cons 0)) [] NONE) + (Call NONE (SOME bvl_num_stubs) [6; 0] NONE))) End Definition evaluate_def: From 7bac70fc64496c3fcb3f882114add9c576030d0a Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Thu, 24 Jul 2025 17:29:01 +0200 Subject: [PATCH 026/112] Attempt to add Thunk into data_to_word invariants --- .../proofs/data_to_word_memoryProofScript.sml | 335 +++++++++++------- 1 file changed, 203 insertions(+), 132 deletions(-) diff --git a/compiler/backend/proofs/data_to_word_memoryProofScript.sml b/compiler/backend/proofs/data_to_word_memoryProofScript.sml index 3225f0d161..ee75559859 100644 --- a/compiler/backend/proofs/data_to_word_memoryProofScript.sml +++ b/compiler/backend/proofs/data_to_word_memoryProofScript.sml @@ -131,7 +131,12 @@ QED (* -- *) Datatype: - tag = BlockTag num | RefTag | BytesTag bool num | NumTag bool | Word64Tag + tag = BlockTag num (* immutable Block *) + | RefTag (* mutable arrays / references *) + | BytesTag bool num (* mutable byte arrays / immutable strings *) + | ThunkTag thunk_mode (* mutable thunks *) + | NumTag bool (* immutable bignum on the heap *) + | Word64Tag (* immutable word64 on the heap *) End Definition BlockRep_def: @@ -234,34 +239,43 @@ Definition ref_edge_def: ref_edge refs (x:num) (y:num) = case lookup x refs of | SOME (ValueArray ys) => MEM y (get_refs (Block 0 ARB ys)) + | SOME (Thunk _ v) => MEM y (get_refs (Block 0 ARB [v])) | _ => F End Definition reachable_refs_def: reachable_refs roots refs t = - ?x r. MEM x roots /\ MEM r (get_refs x) /\ RTC (ref_edge refs) r t + ∃x r. MEM x roots ∧ MEM r (get_refs x) ∧ RTC (ref_edge refs) r t End Definition RefBlock_def: RefBlock xs = DataElement xs (LENGTH xs) (RefTag,[]) End +Definition ThunkBlock_def: + ThunkBlock ev x = DataElement [x] 1 (ThunkTag ev,[]) +End + Definition bc_ref_inv_def: bc_ref_inv conf n refs (f,tf,heap,be) = case (FLOOKUP f n, lookup n refs) of | (SOME x, SOME (ValueArray ys)) => - (?zs. (heap_lookup x heap = SOME (RefBlock zs)) /\ - EVERY2 (\z y. v_inv conf y (z,f,tf,heap)) zs ys) + (∃zs. heap_lookup x heap = SOME (RefBlock zs) ∧ + EVERY2 (λz y. v_inv conf y (z,f,tf,heap)) zs ys) | (SOME x, SOME (ByteArray flag bs)) => let ws = LENGTH bs DIV (dimindex (:α) DIV 8) + 1 in (heap_lookup x heap = SOME (Bytes be flag bs (REPLICATE ws (0w:'a word)))) + | (SOME x, SOME (Thunk ev v)) => + (∃(z:α word_loc heap_address). + heap_lookup x heap = SOME (ThunkBlock ev z) ∧ + v_inv conf v (z,f,tf,heap)) | _ => F End (* TODO: MOVE *) Definition v_all_ts_def: - v_all_ts (Block ts _ xs) = ts :: FLAT (MAP v_all_ts xs) -∧ v_all_ts _ = [] + v_all_ts (Block ts _ xs) = ts :: FLAT (MAP v_all_ts xs) ∧ + v_all_ts _ = [] Termination WF_REL_TAC `measure (v_size)` \\ rpt strip_tac \\ Induct_on `xs` \\ srw_tac [] [v_size_def] \\ res_tac \\ DECIDE_TAC @@ -303,8 +317,12 @@ Definition unused_space_inv_def: data_up_to ptr heap End +Definition isMutTag_def: + isMutTag t ⇔ t = RefTag ∨ ∃ev. t = ThunkTag ev +End + Definition isRef_def: - isRef (DataElement ys l (tag,qs)) = (tag = RefTag) /\ + isRef (DataElement ys l (tag,qs)) = isMutTag tag ∧ isRef _ = F End @@ -587,8 +605,13 @@ Proof \\ Cases_on `lookup n refs` \\ full_simp_tac (srw_ss()) [] \\ full_simp_tac (srw_ss()) [FLOOKUP_DEF,f_o_f_DEF] \\ Cases_on `x'` \\ full_simp_tac (srw_ss()) [] - \\ TRY (fs[Bytes_def,LET_THM] >> res_tac >> simp[ADDR_MAP_def] - \\ rw [] \\ qexists_tac `ws` \\ fs [] >> NO_TAC) + >~ [‘lookup n refs = SOME (ByteArray b l)’] >- + (fs[Bytes_def,LET_THM] \\ res_tac \\ simp[ADDR_MAP_def] + \\ rw [] \\ qexists_tac `ws` \\ fs []) + >~ [‘lookup n refs = SOME (Thunk ev v)’] >- + (fs [ThunkBlock_def] + \\ res_tac \\ fs [] + \\ cheat) \\ res_tac \\ full_simp_tac (srw_ss()) [LENGTH_ADDR_MAP,EVERY2_ADDR_MAP] \\ rpt strip_tac \\ qpat_x_assum `EVERY2 qqq zs l` MP_TAC \\ match_mp_tac EVERY2_IMP_EVERY2 \\ simp_tac std_ss [] \\ rpt strip_tac @@ -602,6 +625,7 @@ Triviality RTC_lemma: gc_shared$gc_related g heap heap2 /\ f ' r IN FDOM g ==> f ' n IN FDOM g Proof + cheat (* ho_match_mp_tac RTC_INDUCT \\ full_simp_tac std_ss [] \\ rpt strip_tac \\ full_simp_tac std_ss [] \\ qpat_x_assum `bb ==> bbb` match_mp_tac \\ full_simp_tac std_ss [] @@ -627,7 +651,7 @@ Proof \\ res_tac \\ CCONTR_TAC \\ full_simp_tac std_ss [] \\ srw_tac [] [] \\ POP_ASSUM MP_TAC \\ simp_tac std_ss [] \\ imp_res_tac MEM_EVERY2_IMP \\ fs [] - \\ fs [] \\ metis_tac [] + \\ fs [] \\ metis_tac [] *) QED Triviality reachable_refs_lemma: @@ -692,8 +716,8 @@ Definition all_reachable_from_roots_def: p IN reachable_addresses roots heap End -val IN_reachable_addresses = - ``x ∈ reachable_addresses roots heap`` +Triviality IN_reachable_addresses = + “x ∈ reachable_addresses roots heap” |> SIMP_CONV std_ss [Once IN_DEF,reachable_addresses_def] Theorem reachable_addresses_related: @@ -811,13 +835,12 @@ QED Definition make_gc_conf_def: make_gc_conf limit = - <| limit := limit; isRef := \x. FST x = RefTag |> - : (tag # 'a) gen_gc$gen_gc_conf + <| limit := limit; isRef := isMutTag o FST |> : (tag # 'a) gen_gc$gen_gc_conf End Triviality gc_move_data_refs_split: - (gen_gc$gc_move cc s x = (x1,s1)) /\ (!t r. (cc.isRef (t,r) <=> t = RefTag)) - /\ EVERY isDataElement s.h2 /\(EVERY (λx. ¬isRef x)) s.h2 /\ EVERY isRef s.r4 ==> + (gen_gc$gc_move cc s x = (x1,s1)) /\ (∀t r. cc.isRef (t,r) <=> isMutTag t) /\ + EVERY isDataElement s.h2 /\ EVERY (λx. ¬isRef x) s.h2 /\ EVERY isRef s.r4 ==> EVERY isDataElement s1.h2 /\ (EVERY (λx. ¬isRef x)) s1.h2 /\ EVERY isRef s1.r4 Proof @@ -831,7 +854,7 @@ QED Triviality gc_move_list_data_refs_split: !x x1 s s1. - (gen_gc$gc_move_list cc s x = (x1,s1)) /\ (!t r. (cc.isRef (t,r) <=> t = RefTag)) + (gen_gc$gc_move_list cc s x = (x1,s1)) /\ (!t r. (cc.isRef (t,r) <=> isMutTag t)) /\ EVERY isDataElement s.h2 /\(EVERY (λx. ¬isRef x)) s.h2 /\ EVERY isRef s.r4 ==> EVERY isDataElement s1.h2 /\(EVERY (λx. ¬isRef x)) s1.h2 /\ EVERY isRef s1.r4 Proof @@ -842,7 +865,7 @@ QED Triviality gc_move_refs_data_refs_split: !cc s s1. - (gen_gc$gc_move_refs cc s = s1) /\ (!t r. (cc.isRef (t,r) <=> t = RefTag)) + (gen_gc$gc_move_refs cc s = s1) /\ (!t r. (cc.isRef (t,r) <=> isMutTag t)) /\ EVERY isDataElement (s.h1++s.h2) /\ (EVERY (λx. ¬isRef x)) (s.h1++s.h2) /\ EVERY isRef (s.r1 ++ s.r2 ++ s.r3 ++ s.r4) ==> EVERY isDataElement (s1.h1++s1.h2) /\ @@ -864,7 +887,7 @@ QED Triviality gc_move_data_data_refs_split: !cc s s1. - (gen_gc$gc_move_data cc s = s1) /\ (!t r. (cc.isRef (t,r) <=> t = RefTag)) + (gen_gc$gc_move_data cc s = s1) /\ (!t r. (cc.isRef (t,r) <=> isMutTag t)) /\ (EVERY (λx. ¬isRef x)) (s.h1++s.h2) /\ EVERY isDataElement (s.h1++s.h2) /\ EVERY isRef (s.r1 ++ s.r2 ++ s.r3 ++ s.r4) ==> @@ -887,7 +910,7 @@ QED Triviality gc_move_loop_data_refs_split: !clock cc s s1. (gen_gc$gc_move_loop cc s clock = s1) /\ - (!t r. (cc.isRef (t,r) <=> t = RefTag)) /\ + (!t r. (cc.isRef (t,r) <=> isMutTag t)) /\ EVERY isDataElement (s.h1++s.h2) /\ (EVERY (λx. ¬isRef x)) (s.h1++s.h2) /\ EVERY isRef (s.r1 ++ s.r2 ++ s.r3 ++ s.r4) ==> @@ -913,7 +936,7 @@ QED Triviality gen_gc_data_refs_split: !cc roots heap. (gen_gc cc (roots,heap) = (roots1,s)) /\ - (!t r. (cc.isRef (t,r) <=> t = RefTag)) ==> + (!t r. (cc.isRef (t,r) <=> isMutTag t)) ==> (EVERY (λx. ¬isRef x)) (s.h1 ++ s.h2) /\ EVERY isDataElement (s.h1 ++ s.h2) /\ EVERY isRef (s.r1 ++ s.r2 ++ s.r3 ++ s.r4) @@ -1171,6 +1194,7 @@ Proof (fs [EVERY_MEM] \\ CCONTR_TAC \\ fs [] \\ Cases_on `x` \\ fs [isRef_def] \\ Cases_on `b` \\ fs [isRef_def] \\ rveq + \\ gvs [isMutTag_def] \\ res_tac \\ fs [] \\ res_tac \\ fs []) \\ fs [EVERY_MEM] \\ CCONTR_TAC \\ fs [] \\ qpat_x_assum `MEM e _` (assume_tac o REWRITE_RULE [MEM_SPLIT]) @@ -1180,10 +1204,10 @@ Proof \\ rveq \\ fs[] \\ `isRef x` by metis_tac [] \\ Cases_on `x` \\ fs [isRef_def] - \\ Cases_on `b` \\ fs [isRef_def] + \\ Cases_on `b` \\ fs [isRef_def,isMutTag_def] \\ Cases_on `e` \\ rveq \\ fs [gen_gc_partialTheory.similar_data_def,isRef_def] - \\ rveq \\ fs[isRef_def]) + \\ rveq \\ fs[isRef_def,isMutTag_def]) \\ fs [roots_ok_def] \\ rpt strip_tac \\ imp_res_tac MEM_ADDR_MAP @@ -1752,10 +1776,11 @@ Theorem isDataElement_lemmas[simp]: isDataElement (Word64Rep (:'a) w) /\ isDataElement (RefBlock ws) /\ isDataElement (Bytes y1 y2 y3 y4) /\ + isDataElement (ThunkBlock ev v) /\ isDataElement (Bignum i) Proof rw [BlockRep_def,isDataElement_def,Bignum_def,i2mw_def, - Word64Rep_def,RefBlock_def,Bytes_def] + Word64Rep_def,RefBlock_def,Bytes_def,ThunkBlock_def] QED (* --- Allocating multiple cons-elements in one go --- *) @@ -1834,7 +1859,7 @@ Theorem list_to_BlockReps_Ref: xs <> [] ==> EVERY (\v. ~isRef v) (list_to_BlockReps conf x len xs) Proof Induct \\ rw [list_to_BlockReps_def, BlockRep_def] - \\ TRY CASE_TAC \\ fs [isRef_def] + \\ TRY CASE_TAC \\ fs [isRef_def,isMutTag_def] QED Theorem list_to_BlockReps_NULL: @@ -1897,8 +1922,7 @@ Theorem list_to_BlockReps_Pointer = Theorem list_to_v_get_refs: !xs t r ts. MEM r (get_refs (list_to_v ts t xs)) ==> - - ?x. (MEM x xs \/ x = t) /\ MEM r (get_refs x) + ∃x. (MEM x xs \/ x = t) /\ MEM r (get_refs x) Proof Induct \\ rw [dataSemTheory.list_to_v_def] \\ fs [get_refs_def] \\ metis_tac [] @@ -2153,8 +2177,10 @@ Definition v_all_vs_def: End Definition all_vs_def: - all_vs refs stack = { v | ∃(n:num) l. lookup n refs = SOME (ValueArray l) ∧ MEM v (v_all_vs l)} ∪ - { v | MEM v (v_all_vs stack)} + all_vs refs stack = + { v | ∃(n:num) l. lookup n refs = SOME (ValueArray l) ∧ MEM v (v_all_vs l)} ∪ + { v | ∃n ev x. lookup n refs = SOME (Thunk ev x) ∧ MEM v (v_all_vs [x])} ∪ + { v | MEM v (v_all_vs stack)} End Theorem v_all_vs_MEM: @@ -2180,6 +2206,7 @@ Theorem v_in_all_vs: x ∈ all_vs refs stack ∧ MEM y (v_all_vs [x]) ⇒ y ∈ all_vs refs stack Proof + cheat (* rw [all_vs_def] >- (disj1_tac \\ cases_on `x` \\ fs [v_all_vs_def] @@ -2190,7 +2217,7 @@ Proof >- (disj2_tac \\ cases_on `x` \\ fs [v_all_vs_def] \\ drule_then ASSUME_TAC v_all_vs_MEM - \\ fs []) + \\ fs []) *) QED Theorem v_all_vs_MEM2: @@ -2258,6 +2285,7 @@ Theorem MEM_in_all_ts: x ∈ all_vs refs stack ∧ MEM ts (v_all_ts x) ⇒ ts ∈ all_ts refs stack Proof + cheat (* Cases \\ rw [all_vs_def,all_ts_def,v_all_ts_def] >- (drule_then ASSUME_TAC v_all_vs_MEM2 \\ fs [] \\ drule_then ASSUME_TAC v_all_vs_ts \\ fs [] @@ -2280,7 +2308,7 @@ Proof \\ `MEM a (v_all_vs [Block n0 n l])` by rw [v_all_vs_def,MEM_v_all_vs] \\ `MEM a (v_all_vs [x])` by metis_tac [v_all_vs_trans] \\ `MEM ts (v_all_ts x)` by metis_tac [v_all_vs_ts_MEM] - \\ metis_tac []) + \\ metis_tac []) *) QED Theorem MEM_in_all_vs: @@ -2380,15 +2408,17 @@ Proof \\ rveq \\ fs []) QED +Triviality v_inv_ind_alt = + v_inv_ind |> Q.SPEC `λv (x,f,tf,heap). P v x f tf heap` + |> SIMP_RULE std_ss [] + |> Q.GEN `P`; + Theorem v_inv_tf_restrict: ∀v y f tf heap conf P. v_inv conf v (y,f,tf,heap) ∧ (∀x. MEM x (v_all_ts v) ⇒ x ∈ P) ⇒ v_inv conf v (y,f, DRESTRICT tf P,heap) Proof - let val ind = theorem "v_inv_ind" |> Q.SPEC `λv (x,f,tf,heap). P v x f tf heap` - |> SIMP_RULE std_ss [] - |> Q.GEN `P` - in ho_match_mp_tac ind end + ho_match_mp_tac v_inv_ind_alt \\ rw [v_inv_def] \\ every_case_tac \\ fs [] \\ qexists_tac `xs` \\ rw [] @@ -2514,9 +2544,13 @@ Proof \\ rpt strip_tac \\ full_simp_tac std_ss [RefBlock_def] \\ Cases_on `FLOOKUP f n` \\ full_simp_tac (srw_ss()) [] \\ Cases_on `lookup n refs` \\ full_simp_tac (srw_ss()) [] - \\ Cases_on `x'` \\ full_simp_tac (srw_ss()) [] - THEN1 ( - imp_res_tac heap_store_rel_lemma \\ full_simp_tac (srw_ss()) [] + \\ rename [‘lookup n refs = SOME x_ref’] + \\ Cases_on ‘x_ref’ \\ full_simp_tac (srw_ss()) [] + >~ [‘lookup n refs = SOME (ByteArray b1 l1)’] >- + (fs[Bytes_def,LET_THM] >> imp_res_tac heap_store_rel_lemma + \\ metis_tac []) + >~ [‘lookup n refs = SOME (ValueArray array_vals)’] >- + (imp_res_tac heap_store_rel_lemma \\ full_simp_tac (srw_ss()) [] \\ qpat_x_assum `EVERY2 PP zs l` MP_TAC \\ match_mp_tac EVERY2_IMP_EVERY2 \\ full_simp_tac (srw_ss()) [] \\ rpt strip_tac \\ res_tac @@ -2524,8 +2558,13 @@ Proof \\ match_mp_tac (GEN_ALL v_inv_SUBMAP) \\ goal_assum (first_x_assum o mp_then Any mp_tac) \\ fs []) - \\ fs[Bytes_def,LET_THM] >> imp_res_tac heap_store_rel_lemma - \\ metis_tac [] + >~ [‘lookup n refs = SOME (Thunk ev thunk_v)’] >- + (fs [ThunkBlock_def] + \\ imp_res_tac heap_store_rel_lemma \\ full_simp_tac (srw_ss()) [] + \\ match_mp_tac v_inv_tf_update_thm \\ asm_rewrite_tac [] + \\ match_mp_tac (GEN_ALL v_inv_SUBMAP) + \\ goal_assum (first_x_assum o mp_then Any mp_tac) + \\ fs []) QED Theorem cons_thm_EMPTY: @@ -2562,6 +2601,7 @@ Theorem word64_alt_thm: (Pointer a (Word 0w)::roots,heap2, be,a + len + 1,sp - len - 1,sp1,gens) limit ts Proof + cheat (* rw[abs_ml_inv_def] \\ qpat_abbrev_tac`wr = DataElement _ _ _` \\ `el_length wr = len + 1` @@ -2666,7 +2706,7 @@ Proof \\ map_every qexists_tac [`n`,`l`] \\ rw [] \\ ho_match_mp_tac MEM_v_all_vs \\ drule MEM_ZIP2 \\ rw [] - \\ rw [EL_MEM]) + \\ rw [EL_MEM]) *) QED (* bignum *) @@ -2681,6 +2721,7 @@ Theorem bignum_alt_thm: abs_ml_inv conf (Number i::stack) refs (Pointer a (Word (0w:α word))::roots,heap2,be,a+len+1,sp-len-1,sp1,gens) limit ts Proof + cheat (* rw[abs_ml_inv_def] \\ qmatch_assum_abbrev_tac`br = DataElement _ _ _` \\ `el_length br = len + 1` by @@ -2787,7 +2828,7 @@ Proof \\ map_every qexists_tac [`n`,`l`] \\ rw [] \\ ho_match_mp_tac MEM_v_all_vs \\ drule MEM_ZIP2 \\ rw [] - \\ rw [EL_MEM]) + \\ rw [EL_MEM]) *) QED (* update ref *) @@ -3101,6 +3142,7 @@ Theorem update_ref_thm: abs_ml_inv conf (xs ++ (RefPtr b ptr)::stack) (insert ptr (ValueArray xs) refs) (roots,heap2,be,a,sp,sp1,gens) limit ts Proof + cheat (* simp_tac std_ss [abs_ml_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def] \\ imp_res_tac EVERY2_APPEND_CONS @@ -3217,7 +3259,7 @@ Proof \\ ho_match_mp_tac MEM_v_all_vs \\ drule MEM_ZIP2 \\ rw [] \\ rw [EL_MEM])) - \\ (full_simp_tac (srw_ss()) [INJ_DEF] \\ metis_tac []) + \\ (full_simp_tac (srw_ss()) [INJ_DEF] \\ metis_tac []) *) QED Definition heap_deref_def: @@ -3240,6 +3282,7 @@ Theorem update_ref_thm1: (insert ptr (ValueArray (LUPDATE (HD xs) i xs1)) refs) (roots,heap2,be,a,sp,sp1,gens) limit ts Proof + cheat (* simp_tac std_ss [abs_ml_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def] \\ imp_res_tac EVERY2_APPEND_CONS @@ -3374,7 +3417,7 @@ Proof \\ ho_match_mp_tac MEM_v_all_vs \\ drule MEM_ZIP2 \\ rw [] \\ rw [EL_MEM])) - \\ full_simp_tac (srw_ss()) [INJ_DEF] \\ metis_tac [] + \\ full_simp_tac (srw_ss()) [INJ_DEF] \\ metis_tac [] *) QED (* update byte ref *) @@ -3476,6 +3519,7 @@ Theorem update_byte_ref_thm: abs_ml_inv conf ((RefPtr b ptr)::stack) (insert ptr (ByteArray fl ys) refs) (roots,h1 ++ [Bytes be fl ys ws] ++ h2,be,a,sp,sp1,gens) limit ts Proof + cheat (* simp_tac std_ss [abs_ml_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def] \\ Cases_on `roots` \\ fs [v_inv_def] \\ rpt var_eq_tac \\ fs [] @@ -3594,7 +3638,7 @@ Proof THEN1 (fs [INJ_DEF,FLOOKUP_DEF] \\ metis_tac []) \\ fs [heap_lookup_APPEND,Bytes_def,heap_length_def,el_length_def,SUM_APPEND] \\ rfs [] \\ rw [] \\ fs [] \\ rfs [heap_lookup_def] - \\ metis_tac[] + \\ metis_tac[] *) QED val heap_store_unused_thm = prove( @@ -3671,6 +3715,7 @@ Theorem new_ref_thm: (rs ++ Pointer (a+sp+sp1-(LENGTH xs + 1)) (Word 0w)::roots2,heap2,be,a, sp - (LENGTH xs + 1),sp1,gens) limit ts Proof + cheat (* simp_tac std_ss [abs_ml_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def] \\ imp_res_tac EVERY2_APPEND_IMP_APPEND @@ -3832,7 +3877,7 @@ Proof \\ map_every qexists_tac [`n`,`l`] \\ fs [lookup_insert] \\ ho_match_mp_tac MEM_v_all_vs - \\ rw [] + \\ rw [] *) QED (* deref *) @@ -3858,6 +3903,7 @@ Theorem deref_thm: abs_ml_inv conf (EL n vs::RefPtr b ptr::stack) refs (y::roots,heap,be,a,sp,sp1,gens) limit ts Proof + cheat (* full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def] \\ rpt strip_tac \\ Cases_on `roots` \\ full_simp_tac (srw_ss()) [LIST_REL_def] \\ full_simp_tac std_ss [v_inv_def] @@ -3909,7 +3955,7 @@ Proof \\ full_simp_tac (srw_ss()) [ref_edge_def,FLOOKUP_DEF,get_refs_def] \\ full_simp_tac (srw_ss()) [MEM_FLAT,MEM_MAP,PULL_EXISTS] \\ qexists_tac `(EL n l)` \\ full_simp_tac std_ss [] - \\ full_simp_tac std_ss [MEM_EL] \\ metis_tac [] + \\ full_simp_tac std_ss [MEM_EL] \\ metis_tac [] *) QED (* el *) @@ -3984,6 +4030,7 @@ Theorem new_byte_alt_thm: (Pointer a (Word 0w)::roots,heap2,be,a + ws + 1, sp - (ws + 1),sp1,gens) limit ts Proof + cheat (* simp_tac std_ss [abs_ml_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def] \\ imp_res_tac EVERY2_APPEND_IMP_APPEND @@ -4106,61 +4153,7 @@ Proof \\ full_simp_tac std_ss [] \\ simp_tac (srw_ss()) [] \\ rpt strip_tac \\ match_mp_tac v_inv_SUBMAP \\ fs [] - \\ fs [heap_store_rel_def,isSomeDataElement_def,PULL_EXISTS] -QED - -(* pop *) - -Theorem pop_thm: - abs_ml_inv conf (xs ++ stack) refs (rs ++ roots,heap,be,a,sp,sp1,gens) limit ts /\ - (LENGTH xs = LENGTH rs) ==> - abs_ml_inv conf (stack) refs (roots,heap,be,a,sp,sp1,gens) limit ts -Proof - full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def] \\ rpt strip_tac - \\ full_simp_tac std_ss [roots_ok_def,MEM_APPEND] - THEN1 (rw [] \\ res_tac \\ fs []) - \\ qexists_tac `f` \\ full_simp_tac std_ss [] - \\ qexists_tac `DRESTRICT tf (all_ts refs stack)` \\ full_simp_tac std_ss [] - \\ conj_tac - >- fs [INJ_DEF,DRESTRICT_DEF] - \\ conj_tac - >- fs [SUBSET_DEF,DRESTRICT_DEF] - \\ conj_tac - >- fs [SUBSET_DEF,DRESTRICT_DEF,IN_INTER] - \\ conj_tac - >- (match_mp_tac EVERY2_MEM_MONO - \\ imp_res_tac LIST_REL_APPEND_IMP - \\ first_assum(part_match_exists_tac(last o strip_conj) o concl) - \\ simp[FORALL_PROD] \\ rw[] - \\ ho_match_mp_tac v_inv_tf_restrict - \\ rw [] - \\ ho_match_mp_tac MEM_in_all_ts - \\ qexists_tac `p_1` \\ rw [] - \\ ho_match_mp_tac MEM_stack_all_vs - \\ drule MEM_ZIP2 \\ rw [] - \\ rw [EL_MEM]) - \\ fs[reachable_refs_def,PULL_EXISTS] - \\ rw[] - \\ fs[bc_ref_inv_def] - \\ fsrw_tac[boolSimps.DNF_ss][] - \\ first_x_assum rpt_drule - \\ BasicProvers.TOP_CASE_TAC \\ fs[] - \\ BasicProvers.TOP_CASE_TAC \\ fs[] - \\ BasicProvers.TOP_CASE_TAC \\ fs[] \\ rw[] - \\ fs[RefBlock_def,Bytes_def] - \\ match_mp_tac EVERY2_MEM_MONO - \\ imp_res_tac LIST_REL_APPEND_IMP - \\ first_assum(part_match_exists_tac(last o strip_conj) o concl) - \\ simp[FORALL_PROD] \\ rw[] - \\ ho_match_mp_tac v_inv_tf_restrict - \\ rw [] - \\ ho_match_mp_tac MEM_in_all_ts - \\ qexists_tac `p_2` \\ rw [] - \\ rw [all_vs_def] \\ disj1_tac - \\ map_every qexists_tac [`n`,`l`] \\ rw [] - \\ ho_match_mp_tac MEM_v_all_vs - \\ drule MEM_ZIP2 \\ rw [] - \\ rw [EL_MEM] + \\ fs [heap_store_rel_def,isSomeDataElement_def,PULL_EXISTS] *) QED (* equality *) @@ -4224,7 +4217,8 @@ QED (* permute stack *) Theorem all_ts_permute: - ∀(refs : v ref num_map) stack stack'. PERM stack stack' ⇒ all_ts refs stack = all_ts refs stack' + ∀(refs : v ref num_map) stack stack'. + PERM stack stack' ⇒ all_ts refs stack = all_ts refs stack' Proof strip_tac \\ ho_match_mp_tac PERM_IND @@ -4300,20 +4294,43 @@ Proof \\ fs[bc_ref_inv_def] \\ Cases_on `FLOOKUP f n` \\ fs [] \\ Cases_on `lookup n refs` \\ fs [] - \\ Cases_on `x'` \\ rw [] - \\ qexists_tac `zs` \\ rw [] - \\ match_mp_tac EVERY2_MEM_MONO - \\ imp_res_tac LIST_REL_APPEND_IMP - \\ first_assum(part_match_exists_tac(last o strip_conj) o concl) - \\ simp[FORALL_PROD] \\ rw[] - \\ ho_match_mp_tac v_inv_tf_restrict - \\ rw [] \\ ho_match_mp_tac MEM_in_all_ts - \\ qexists_tac `p_2` \\ rw [] - \\ rw [all_vs_def] \\ disj1_tac - \\ map_every qexists_tac [`n`,`l`] \\ rw [] - \\ ho_match_mp_tac MEM_v_all_vs - \\ drule MEM_ZIP2 \\ rw [] - \\ rw [EL_MEM] + \\ rename [‘lookup n refs = SOME x_ref’] + \\ Cases_on ‘x_ref’ \\ rw [] + >~ [‘RefBlock’] >- + (qexists_tac `zs` \\ rw [] + \\ match_mp_tac EVERY2_MEM_MONO + \\ imp_res_tac LIST_REL_APPEND_IMP + \\ first_assum(part_match_exists_tac(last o strip_conj) o concl) + \\ simp[FORALL_PROD] \\ rw[] + \\ ho_match_mp_tac v_inv_tf_restrict + \\ rw [] \\ ho_match_mp_tac MEM_in_all_ts + \\ qexists_tac `p_2` \\ rw [] + \\ rw [all_vs_def] \\ rpt disj1_tac + \\ map_every qexists_tac [`n`,`l`] \\ rw [] + \\ ho_match_mp_tac MEM_v_all_vs + \\ drule MEM_ZIP2 \\ rw [] + \\ rw [EL_MEM]) + >~ [‘ThunkBlock’] >- + (qexists_tac `z` \\ rw [] + \\ ho_match_mp_tac v_inv_tf_restrict + \\ rw [] \\ ho_match_mp_tac MEM_in_all_ts + \\ pop_assum $ irule_at $ Pos last + \\ rw [all_vs_def] \\ disj1_tac \\ disj2_tac + \\ first_x_assum $ irule_at $ Pos hd + \\ irule MEM_v_all_vs \\ simp []) +QED + +(* pop *) + +Theorem pop_thm: + abs_ml_inv conf (xs ++ stack) refs (rs ++ roots,heap,be,a,sp,sp1,gens) limit ts /\ + (LENGTH xs = LENGTH rs) ==> + abs_ml_inv conf (stack) refs (roots,heap,be,a,sp,sp1,gens) limit ts +Proof + strip_tac + \\ irule (abs_ml_inv_stack_permute |> Q.SPECL [‘xs’,‘[]’] |> SRULE []) + \\ qexists_tac ‘ZIP(xs,rs)’ + \\ simp [MAP_ZIP] QED (* duplicate *) @@ -4366,7 +4383,9 @@ Theorem split1_thm: ?rs1 roots1. (roots = rs1 ++ roots1) /\ (LENGTH rs1 = LENGTH xs1) Proof full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def,GSYM APPEND_ASSOC] - \\ rpt strip_tac \\ NTAC 5 (imp_res_tac LIST_REL_SPLIT1 \\ imp_res_tac LIST_REL_LENGTH) \\ metis_tac [] + \\ rpt strip_tac + \\ NTAC 5 (imp_res_tac LIST_REL_SPLIT1 \\ imp_res_tac LIST_REL_LENGTH) + \\ metis_tac [] QED Theorem split2_thm: @@ -4375,7 +4394,9 @@ Theorem split2_thm: (LENGTH rs1 = LENGTH xs1) /\ (LENGTH rs2 = LENGTH xs2) Proof full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def,GSYM APPEND_ASSOC] - \\ rpt strip_tac \\ NTAC 5 (imp_res_tac LIST_REL_SPLIT1 \\ imp_res_tac LIST_REL_LENGTH) \\ metis_tac [] + \\ rpt strip_tac + \\ NTAC 5 (imp_res_tac LIST_REL_SPLIT1 \\ imp_res_tac LIST_REL_LENGTH) + \\ metis_tac [] QED Theorem split3_thm: @@ -4385,7 +4406,9 @@ Theorem split3_thm: (LENGTH rs3 = LENGTH xs3) Proof full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def,GSYM APPEND_ASSOC] - \\ rpt strip_tac \\ NTAC 5 (imp_res_tac LIST_REL_SPLIT1 \\ imp_res_tac LIST_REL_LENGTH) \\ metis_tac [] + \\ rpt strip_tac + \\ NTAC 5 (imp_res_tac LIST_REL_SPLIT1 \\ imp_res_tac LIST_REL_LENGTH) + \\ metis_tac [] QED Theorem abs_ml_inv_Num: @@ -4469,6 +4492,11 @@ Proof EVAL_TAC QED +Definition thunk_tag_to_bits_def: + thunk_tag_to_bits Evaluated = 1w ∧ + thunk_tag_to_bits NotEvaluated = 0w +End + Definition word_payload_def: (word_payload ys l (BlockTag n) qs conf = (* header: ...00[11] here i in ...i[11] must be 0 for the GC *) @@ -4482,6 +4510,11 @@ Definition word_payload_def: (make_header conf 2w (LENGTH ys), MAP (word_addr conf) ys, (qs = []) /\ (LENGTH ys = l))) /\ + (word_payload ys l (ThunkTag e) qs conf = + (* header: ...e110[11] here i in ...i[11] must be 0 for the GC *) + (make_header conf (thunk_tag_to_bits e << 3 || 6w) (LENGTH ys), + MAP (word_addr conf) ys, + (qs = []) /\ (LENGTH ys = 1) ∧ l = 1)) /\ (word_payload ys l Word64Tag qs conf = (* header: ...011[11] here i in ...i[11] must be 1 for the GC *) (make_header conf 3w l, @@ -4953,6 +4986,7 @@ Theorem all_ts_head_eq: v ∈ all_vs refs stack ⇒ all_ts refs stack = all_ts refs (v::stack) Proof + cheat (* rw [FUN_EQ_THM] \\ EQ_TAC >- (rw [all_ts_def,all_vs_def] \\ metis_tac []) @@ -4984,7 +5018,7 @@ Proof \\ ho_match_mp_tac v_all_vs_ts_MEM \\ qexists_tac `Block n0 n l` \\ rw [v_all_ts_def]) - >- metis_tac [] + >- metis_tac [] *) QED Theorem memory_rel_El': @@ -5240,6 +5274,7 @@ val gc_kind_update_Ref = prove( (ha ++ DataElement (ys1 ++ y::ys2) l (RefTag,[])::hb) ==> gc_kind_inv c a sp sp1 gens (ha ++ DataElement (ys1 ++ z::ys2) l (RefTag,[])::hb)``, + cheat (* fs [gc_kind_inv_def] \\ every_case_tac \\ fs [] \\ ntac 2 strip_tac THEN1 (Cases_on `gens` \\ fs [gen_state_ok_def,EVERY_MEM] @@ -5261,7 +5296,7 @@ val gc_kind_update_Ref = prove( \\ CASE_TAC \\ rw [] \\ fs [isRef_def] \\ fs [heap_split_def,el_length_def] \\ rfs [] \\ rpt (CASE_TAC \\ fs []) - \\ rveq \\ fs [isRef_def]); + \\ rveq \\ fs [isRef_def] *)); Theorem v_all_vs_append: ∀x y. v_all_vs (x ++ y) = v_all_vs x ++ v_all_vs y @@ -7240,6 +7275,39 @@ Proof \\ fs [fcpTheory.FCP_BETA,word_lsl_def,word_index] QED +Theorem memory_rel_Thunk_IMP: + memory_rel c be ts refs sp st m dm ((RefPtr bl p,v:'a word_loc)::vars) /\ + lookup p refs = SOME (Thunk ev x) /\ good_dimindex (:'a) ==> + ?w a x. + v = Word w /\ w ' 0 /\ word_bit 3 x /\ ~word_bit 2 x /\ word_bit 4 x /\ + get_real_simple_addr c st w = SOME a /\ + get_real_addr c st w = SOME a /\ + m a = Word x /\ a IN dm /\ + decode_length c x = 1w /\ + (word_bit 5 x ⇔ ev = Evaluated) +Proof + fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def, + bc_stack_ref_inv_def,v_inv_def,word_addr_def] \\ rw [get_addr_0] + \\ `bc_ref_inv c p refs (f,tf,heap,be)` by + (first_x_assum match_mp_tac \\ fs [reachable_refs_def] + \\ qexists_tac `RefPtr bl p` \\ fs [get_refs_def]) + \\ pop_assum mp_tac \\ simp [bc_ref_inv_def] + \\ fs [FLOOKUP_DEF] \\ rw [] + \\ fs [word_addr_def,heap_in_memory_store_def] + \\ rpt_drule get_real_addr_get_addr \\ disch_then kall_tac + \\ imp_res_tac heap_lookup_SPLIT \\ clean_tac + \\ fs [word_heap_APPEND,word_heap_def,ThunkBlock_def,word_el_def, + word_payload_def,word_list_def] + \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR] + \\ imp_res_tac EVERY2_LENGTH \\ SEP_R_TAC \\ fs [get_addr_0] + \\ fs [make_header_def,word_bit_def,word_or_def,fcpTheory.FCP_BETA] + \\ fs [good_dimindex_def] + \\ fs [fcpTheory.FCP_BETA,word_lsl_def,word_index] + \\ Cases_on ‘ev’ + \\ fs [thunk_tag_to_bits_def] + \\ EVAL_TAC +QED + val expand_num = DECIDE ``4 = SUC 3 /\ 3 = SUC 2 /\ 2 = SUC 1 /\ 1 = SUC 0 /\ 5 = SUC 4 /\ 6 = SUC 5 /\ 7 = SUC 6 /\ 8 = SUC 7`` @@ -7866,7 +7934,7 @@ Theorem memory_rel_RefPtr_IMP': memory_rel c be ts refs sp st m dm ((RefPtr bl p,v)::vars) ∧ good_dimindex (:α) ⇒ ∃w a x. - v = Word w ∧ w ' 0 ∧ (word_bit 4 x ⇒ word_bit 2 x) ∧ + v = Word w ∧ w ' 0 ∧ (* (word_bit 4 x ⇒ word_bit 2 x) ∧ *) (word_bit 3 x ⇔ ¬word_bit 2 x) ∧ data_to_word_memoryProof$get_real_addr c st w = SOME a ∧ get_real_simple_addr c st w = SOME a ∧ @@ -7874,15 +7942,16 @@ Theorem memory_rel_RefPtr_IMP': Proof strip_tac \\ drule memory_rel_RefPtr_IMP_lemma \\ strip_tac \\ Cases_on `res` \\ fs [] - THEN1 (rpt_drule memory_rel_ValueArray_IMP \\ rw [] \\ fs []) - THEN1 (rpt_drule memory_rel_ByteArray_IMP \\ rw [] \\ fs []) + THEN1 (drule_all memory_rel_ValueArray_IMP \\ rw [] \\ fs []) + THEN1 (drule_all memory_rel_ByteArray_IMP \\ rw [] \\ fs []) + THEN1 (drule_all memory_rel_Thunk_IMP \\ rw [] \\ fs []) QED Theorem memory_rel_RefPtr_IMP: memory_rel c be ts refs sp st m dm ((RefPtr bl p,v:'a word_loc)::vars) /\ good_dimindex (:'a) ==> ?w a x. - v = Word w /\ w ' 0 /\ (word_bit 4 x ==> word_bit 2 x) /\ + v = Word w /\ w ' 0 /\ (* (word_bit 4 x ==> word_bit 2 x) /\ *) (word_bit 3 x <=> ~word_bit 2 x) /\ get_real_addr c st w = SOME a /\ m a = Word x /\ a IN dm Proof @@ -9838,6 +9907,7 @@ Theorem word_eq_thm0: (b <=> (res = 1w)) /\ l <= l1 + (LENGTH v1 + SUM (MAP vb_size v1)) * dimword (:'a)) Proof + cheat (* ho_match_mp_tac do_eq_ind \\ rpt conj_tac \\ once_rewrite_tac [do_eq_def] \\ simp [] THEN1 (* do_eq Numbers *) @@ -10129,7 +10199,7 @@ Proof (CONJUNCT2 word_eq_min_max_clock) \\ PURE_ONCE_REWRITE_TAC[MAX_COMM] \\ fs[ETA_THM] - \\ fs[LEFT_ADD_DISTRIB] + \\ fs[LEFT_ADD_DISTRIB] *) QED Theorem word_eq_thm: @@ -12005,6 +12075,7 @@ Theorem cons_multi_thm: ++ heap2, be, a + heap_length Allocd, sp - heap_length Allocd, sp1, gens) limit (ts + LENGTH xs) Proof + cheat (* rw [abs_ml_inv_def] \\ qpat_x_assum `bc_stack_ref_inv _ _ _ _ _` mp_tac \\ simp [Once bc_stack_ref_inv_def] \\ strip_tac @@ -12309,7 +12380,7 @@ Proof \\ qpat_x_assum `LENGTH xs = _` (assume_tac o GSYM) \\ rw [] \\ match_mp_tac (Q.INST [`sp`|->`sp+sp1`] (SPEC_ALL v_inv_list_to_v)) - \\ unlength_tac [heap_expand_def] + \\ unlength_tac [heap_expand_def] *) QED Theorem memory_rel_append: @@ -13823,14 +13894,14 @@ Proof >- (simp [AllCaseEqs()] \\ rw [] \\ gvs [SF SFY_ss] - \\ gvs [Bytes_def,isRef_def]) + \\ gvs [Bytes_def,isRef_def,isMutTag_def]) \\ gvs [heap_split_def,el_length_Bytes] \\ IF_CASES_TAC \\ gvs [] - >- (rw [] \\ gvs [isRef_def,Bytes_def]) + >- (rw [] \\ gvs [isRef_def,Bytes_def,isMutTag_def]) \\ IF_CASES_TAC \\ gvs [] \\ simp [AllCaseEqs()] \\ rpt strip_tac \\ gvs [] - \\ gvs [Bytes_def,isRef_def]) + \\ gvs [Bytes_def,isRef_def,isMutTag_def]) \\ ‘unused_space_inv a (sp' + sp1) heap1’ by (gvs [unused_space_inv_def,SF DNF_ss] \\ gvs [data_up_to_def] @@ -13844,7 +13915,7 @@ Proof \\ IF_CASES_TAC \\ simp [] \\ simp [AllCaseEqs()] \\ rw [] \\ gvs [SF SFY_ss] - \\ gvs [Bytes_def,isRef_def]) + \\ gvs [Bytes_def,isRef_def,isMutTag_def]) \\ ‘all_ts (insert p2 (ByteArray fl2 res_vals) refs) = all_ts refs’ by (gvs [all_ts_def,FUN_EQ_THM,lookup_insert,CaseEq"bool"] From c42d798dbf1ad86cf93230a8467d9be85db09992 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Fri, 25 Jul 2025 07:04:09 +0200 Subject: [PATCH 027/112] Various minor tweaks --- .../proofs/data_to_wordProofScript.sml | 5 +- .../proofs/data_to_word_assignProofScript.sml | 23 +++- .../proofs/data_to_word_gcProofScript.sml | 112 ++++++++++++------ .../backend/proofs/word_gcFunctionsScript.sml | 2 +- compiler/backend/stack_allocScript.sml | 4 +- 5 files changed, 101 insertions(+), 45 deletions(-) diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml index d074cef386..de8368a156 100644 --- a/compiler/backend/proofs/data_to_wordProofScript.sml +++ b/compiler/backend/proofs/data_to_wordProofScript.sml @@ -248,7 +248,10 @@ Proof \\ imp_res_tac word_ml_inv_get_var_IMP \\ match_mp_tac word_ml_inv_insert \\ full_simp_tac(srw_ss())[]) >~ [‘evaluate (Assign _ _ _ _,s)’] >- - (full_simp_tac(srw_ss())[comp_def,dataSemTheory.evaluate_def,wordSemTheory.evaluate_def] + (Cases_on ‘op = ThunkOp ForceThunk’ + >- cheat + \\ full_simp_tac std_ss [] + \\ full_simp_tac(srw_ss())[comp_def,dataSemTheory.evaluate_def,wordSemTheory.evaluate_def] \\ imp_res_tac (METIS_PROVE [] ``(if b1 /\ b2 then x1 else x2) = y ==> b1 /\ b2 /\ x1 = y \/ (b1 ==> ~b2) /\ x2 = y``) diff --git a/compiler/backend/proofs/data_to_word_assignProofScript.sml b/compiler/backend/proofs/data_to_word_assignProofScript.sml index 267bd8e469..9fe4b91235 100644 --- a/compiler/backend/proofs/data_to_word_assignProofScript.sml +++ b/compiler/backend/proofs/data_to_word_assignProofScript.sml @@ -1963,6 +1963,7 @@ fun cases_on_op q = Cases_on q >| Theorem do_app_aux_safe_for_space_mono: (do_app_aux op xs s = Rval (r,s1)) /\ s1.safe_for_space ==> s.safe_for_space Proof + cheat (* cases_on_op `op` \\ fs [do_app_aux_def,list_case_eq,option_case_eq,v_case_eq,AllCaseEqs(), bool_case_eq,ffiTheory.call_FFI_def,do_app_def,do_space_def, @@ -1972,7 +1973,7 @@ Proof pair_case_eq,consume_space_def,dataLangTheory.op_space_reset_def,data_spaceTheory.op_space_req_def] \\ rw [] \\ fs [state_component_equality] \\ rw [] \\ rpt (pairarg_tac \\ fs []) - \\ EVERY_CASE_TAC \\ fs [] + \\ EVERY_CASE_TAC \\ fs [] *) QED Theorem do_app_safe_for_space_allowed_op: @@ -4696,6 +4697,18 @@ Proof \\ drule ALOOKUP_MEM \\ simp [] QED +Theorem assign_AllocThunk: + op = ThunkOp (AllocThunk ev) ==> ^assign_thm_goal +Proof + cheat +QED + +Theorem assign_UpdateThunk: + op = ThunkOp (UpdateThunk ev) ==> ^assign_thm_goal +Proof + cheat +QED + Theorem assign_ConfigGC: op = MemOp ConfigGC ==> ^assign_thm_goal Proof @@ -13939,9 +13952,10 @@ Proof[exclude_simps = EXP_LE_LOG_SIMP EXP_LT_LOG_SIMP LE_EXP_LOG_SIMP QED Theorem assign_thm: - ^assign_thm_goal + op ≠ ThunkOp ForceThunk ⇒ ^assign_thm_goal Proof - Cases_on `op = GlobOp AllocGlobal` \\ fs [] + strip_tac + \\ Cases_on `op = GlobOp AllocGlobal` \\ fs [] THEN1 (fs [do_app] \\ every_case_tac \\ fs []) \\ Cases_on `op = IntOp Greater` \\ fs [] THEN1 (fs [do_app] \\ every_case_tac \\ fs []) @@ -13958,9 +13972,10 @@ Proof \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] \\ qsuff_tac `assign c n l dest op args names_opt = (GiveUp,l)` \\ fs [] \\ `?f. f () = op` by (qexists_tac `K op` \\ fs []) (* here for debugging only *) + \\ cheat (* \\ cases_on_op `op` \\ fs [assign_def] \\ rpt (PURE_CASE_TAC \\ fs []) - \\ qhdtm_x_assum`do_app`mp_tac \\ EVAL_TAC + \\ qhdtm_x_assum`do_app`mp_tac \\ EVAL_TAC *) QED val _ = export_theory(); diff --git a/compiler/backend/proofs/data_to_word_gcProofScript.sml b/compiler/backend/proofs/data_to_word_gcProofScript.sml index ecf19a8c4d..005143f5c0 100644 --- a/compiler/backend/proofs/data_to_word_gcProofScript.sml +++ b/compiler/backend/proofs/data_to_word_gcProofScript.sml @@ -1230,30 +1230,29 @@ QED Theorem is_ref_header_alt: good_dimindex (:'a) ==> - (is_ref_header (w:'a word) <=> ~(w ' 2) /\ (w ' 3) /\ ~(w ' 4)) + (is_ref_header (w:'a word) <=> ~(w ' 2) /\ (w ' 3)) Proof fs [is_ref_header_def,fcpTheory.CART_EQ,good_dimindex_def] \\ rw [] \\ fs [word_and_def,word_index,fcpTheory.FCP_BETA] \\ rw [] \\ eq_tac \\ rw [] \\ fs [] \\ TRY (qpat_x_assum `!x._` (fn th => qspec_then `2` mp_tac th - \\ qspec_then `3` mp_tac th - \\ qspec_then `4` mp_tac th )) + \\ qspec_then `3` mp_tac th)) \\ fs [] \\ Cases_on `i = 2` - \\ fs [] \\ Cases_on `i = 3` - \\ fs [] \\ Cases_on `i = 4` \\ fs [] + \\ fs [] \\ Cases_on `i = 3` \\ fs [] QED Theorem is_ref_header_thm: (word_payload addrs ll tt0 tt1 conf = (h,ts,c5)) /\ good_dimindex (:'a) /\ conf.len_size + 5 <= dimindex (:'a) ==> - (is_ref_header (h:'a word) ⇔ tt0 = RefTag) + (is_ref_header (h:'a word) ⇔ isMutTag tt0) Proof Cases_on `tt0` \\ fs [word_payload_def] \\ rw [] \\ fs [make_header_def,make_byte_header_def,is_ref_header_alt] \\ fs [word_or_def,fcpTheory.FCP_BETA,good_dimindex_def,word_lsl_def,word_index] \\ rw [] \\ fs [word_or_def,fcpTheory.FCP_BETA,good_dimindex_def,word_lsl_def,word_index] + \\ simp [isMutTag_def] QED Definition is_Ref_def: @@ -1270,7 +1269,7 @@ End Theorem word_gen_gc_move_thm: (gen_gc$gc_move gen_conf s x = (x1,s1)) /\ s1.ok /\ s.h2 = [] /\ s.r4 = [] /\ heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\ - (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\ + (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\ conf.len_size + 5 <= dimindex (:'a) /\ (word_heap curr s.heap conf * word_list pa xs * frame) (fun2set (m,dm)) /\ @@ -1340,7 +1339,7 @@ Proof \\ drule is_ref_header_thm \\ asm_simp_tac std_ss [] \\ disch_then kall_tac - \\ reverse (Cases_on `tt0 = RefTag`) \\ fs [] + \\ reverse (Cases_on `isMutTag tt0`) \\ fs [] THEN1 (pairarg_tac \\ full_simp_tac(srw_ss())[] \\ pairarg_tac \\ full_simp_tac(srw_ss())[] @@ -1536,7 +1535,7 @@ Theorem word_gen_gc_move_roots_thm: !x xs x1 w s1 s pb1 pa1 pa m1 m ib1 i1 frame dm curr c1. (gen_gc$gc_move_list gen_conf s x = (x1,s1)) /\ s1.ok /\ s.h2 = [] /\ s.r4 = [] /\ heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\ - (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\ + (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\ conf.len_size + 5 <= dimindex (:'a) /\ (word_heap curr s.heap conf * word_list pa xs * frame) (fun2set (m,dm)) /\ @@ -1590,7 +1589,7 @@ Theorem word_gen_gc_move_list_thm = Q.prove(` !x xs x1 w s1 s pb1 pa1 pa m1 m ib1 i1 frame dm curr c1 k k1. (gen_gc$gc_move_list gen_conf s x = (x1,s1)) /\ s1.ok /\ s.h2 = [] /\ s.r4 = [] /\ heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\ - (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\ + (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\ conf.len_size + 5 <= dimindex (:'a) /\ (word_heap curr s.heap conf * word_list pa xs * word_list k (MAP (word_addr conf) x) * frame) (fun2set (m,dm)) /\ @@ -1855,12 +1854,29 @@ Proof \\ drule word_list_IMP_limit \\ fs [] QED +Definition muttag_header_def: + muttag_header (ThunkTag e) = (thunk_tag_to_bits e ≪ 3 ‖ 6w) ∧ + muttag_header _ = 2w +End + +Theorem isMutTag_word_payload_IMP: + ∀x1 x2 x3. + word_payload ys l t qs conf = (x1,x2,x3) ∧ + isMutTag t ⇒ + x1 = make_header conf (muttag_header t) (LENGTH ys) ∧ + x2 = MAP (word_addr conf) ys ∧ + x3 = (qs = [] ∧ LENGTH ys = l ∧ (t ≠ RefTag ⇒ l = 1)) +Proof + rw [isMutTag_def,muttag_header_def] + \\ fs [word_payload_def,SF CONJ_ss,muttag_header_def] +QED + Theorem word_gen_gc_move_refs_thm: !k s m dm curr xs s1 pb1 pa1 m1 ib1 i1 frame c1 p1. (gen_gc$gc_move_refs gen_conf s = s1) /\ s1.ok /\ heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\ heap_length s.heap * (dimindex (:'a) DIV 8) < dimword (:'a) /\ - (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\ + (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\ conf.len_size + 5 <= dimindex (:'a) /\ (word_gen_gc_move_refs conf k ((* r2a *) p + bytes_in_word * @@ -1953,6 +1969,14 @@ Proof \\ fs [word_heap_parts_def,word_heap_APPEND,word_heap_def,word_el_def, heap_length_APPEND,word_payload_def,GSYM word_add_n2w, WORD_LEFT_ADD_DISTRIB,word_list_def] + \\ pairarg_tac \\ fs [] + \\ dxrule_then drule isMutTag_word_payload_IMP + \\ strip_tac \\ rveq + \\ fs [word_heap_parts_def,word_heap_APPEND,word_heap_def,word_el_def, + heap_length_APPEND,word_payload_def,GSYM word_add_n2w, + WORD_LEFT_ADD_DISTRIB,word_list_def] + \\ fs [heap_length_def,el_length_def] + \\ fs [GSYM heap_length_def] \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR] \\ rfs [] \\ rveq \\ ntac 4 (pop_assum mp_tac) \\ SEP_R_TAC \\ fs [theWord_def,isWord_def] @@ -1994,6 +2018,12 @@ Proof \\ `LENGTH xs' = LENGTH l` by (imp_res_tac gen_gcTheory.gc_move_list_length \\ fs []) \\ qunabbrev_tac `newp` + \\ fs [word_heap_parts_def,word_heap_APPEND,word_heap_def,word_el_def, + heap_length_APPEND,word_payload_def,GSYM word_add_n2w,SUM_APPEND, + WORD_LEFT_ADD_DISTRIB,word_list_def,el_length_def,heap_length_def] + \\ pairarg_tac \\ fs [] + \\ dxrule_then drule isMutTag_word_payload_IMP + \\ strip_tac \\ rveq \\ fs [word_heap_parts_def,word_heap_APPEND,word_heap_def,word_el_def, heap_length_APPEND,word_payload_def,GSYM word_add_n2w,SUM_APPEND, WORD_LEFT_ADD_DISTRIB,word_list_def,el_length_def,heap_length_def] @@ -2017,7 +2047,7 @@ Theorem word_gen_gc_move_data_thm: heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\ heap_length s.heap * (dimindex (:'a) DIV 8) < dimword (:'a) /\ conf.len_size + 2 < dimindex (:α) /\ - (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\ + (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\ conf.len_size + 5 <= dimindex (:'a) /\ (word_gen_gc_move_data conf k ((* h2a *) p + bytes_in_word * n2w (heap_length s.h1), @@ -2225,7 +2255,7 @@ Theorem word_gen_gc_move_loop_thm: heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\ heap_length s.heap * (dimindex (:'a) DIV 8) < dimword (:'a) /\ conf.len_size + 2 < dimindex (:α) /\ s.r3 = [] /\ s.r2 = [] /\ - (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\ + (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\ conf.len_size + 5 <= dimindex (:'a) /\ (word_gen_gc_move_loop conf k ((* pax *) p + bytes_in_word * n2w (heap_length s.h1), @@ -2381,7 +2411,7 @@ Theorem word_gen_gc_thm: heap_length heap <= dimword (:'a) DIV 2 ** shift_length conf /\ heap_length heap * (dimindex (:'a) DIV 8) < dimword (:'a) /\ conf.len_size + 2 < dimindex (:α) /\ - (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\ + (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\ conf.len_size + 5 <= dimindex (:'a) /\ good_dimindex (:'a) /\ (word_heap curr heap conf * @@ -2479,9 +2509,9 @@ Proof QED Theorem heap_drop_0: - heap_drop 0 h = h + heap_drop 0 h = h Proof -Cases_on `h` >> fs[heap_drop_def,heap_split_def] + Cases_on `h` >> fs[heap_drop_def,heap_split_def] QED Theorem gc_forward_ptr_heap_split: @@ -2569,7 +2599,7 @@ Theorem word_gen_gc_partial_move_thm: (heap_segment (gc_conf.gen_start,gc_conf.refs_start) gcstate.heap = SOME(old,current,refs)) /\ heap_length gcstate.heap * (dimindex (:α) DIV 8) < dimword (:α) /\ (word_heap (curr + bytes_in_word * n2w(heap_length old)) current conf * word_list pa xs * frame) (fun2set (m,dm)) /\ - (!t r. (gc_conf.isRef (t,r) <=> t = RefTag)) /\ + (!t r. (gc_conf.isRef (t,r) <=> isMutTag t)) /\ (word_gen_gc_partial_move conf (word_addr conf x,n2w gcstate.a,pa,curr,m,dm, bytes_in_word * n2w gc_conf.gen_start, bytes_in_word * n2w gc_conf.refs_start) = @@ -2685,7 +2715,7 @@ Proof \\ drule is_ref_header_thm \\ asm_simp_tac std_ss [] \\ disch_then kall_tac - \\ reverse (Cases_on `tt0 = RefTag`) \\ fs [] + \\ reverse (Cases_on `isMutTag tt0`) \\ fs [] THEN1 (pairarg_tac \\ full_simp_tac(srw_ss())[] \\ pairarg_tac \\ full_simp_tac(srw_ss())[] @@ -2993,7 +3023,7 @@ Theorem word_gen_gc_partial_move_roots_thm: gen_conf.gen_start <= gen_conf.refs_start /\ gen_conf.refs_start <= heap_length s.heap /\ (heap_segment (gen_conf.gen_start,gen_conf.refs_start) s.heap = SOME(old,current,refs)) /\ - (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\ + (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\ heap_length s.heap * (dimindex (:α) DIV 8) < dimword (:α) /\ (word_heap (curr + bytes_in_word * n2w(heap_length old)) current conf * word_list pa xs * frame) (fun2set (m,dm)) /\ (word_gen_gc_partial_move_roots conf (MAP (word_addr conf) x,n2w s.a,pa, @@ -3061,7 +3091,7 @@ Theorem word_gen_gc_partial_move_list_thm: gen_conf.gen_start <= gen_conf.refs_start /\ gen_conf.refs_start <= heap_length s.heap /\ (heap_segment (gen_conf.gen_start,gen_conf.refs_start) s.heap = SOME(old,current,refs)) /\ - (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\ + (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\ heap_length s.heap * (dimindex (:α) DIV 8) < dimword (:α) /\ (word_heap (curr + bytes_in_word * n2w(heap_length old)) current conf * word_list pa xs * word_list k (MAP (word_addr conf) x) * frame) (fun2set (m,dm)) /\ @@ -3174,7 +3204,7 @@ Theorem word_gen_gc_partial_move_data_thm: gen_conf.refs_start <= heap_length s.heap /\ (heap_segment (gen_conf.gen_start,gen_conf.refs_start) s.heap = SOME(old,current,refs)) /\ conf.len_size + 2 < dimindex (:α) /\ - (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\ + (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\ (word_gen_gc_partial_move_data conf k ((* h2a *) p + bytes_in_word * n2w (heap_length s.h1), n2w s.a, @@ -3378,7 +3408,6 @@ Proof WORD_LEFT_ADD_DISTRIB,word_list_def,el_length_def,heap_length_def] QED - Theorem word_gen_gc_partial_move_ref_list_thm: !x ck xs x1 s1 s pa1 pa m1 m i1 frame dm curr c1 k old current refs. (gen_gc_partial$gc_move_ref_list gen_conf s x = (x1,s1)) /\ s1.ok /\ s.h2 = [] /\ s.r4 = [] /\ @@ -3390,7 +3419,7 @@ Theorem word_gen_gc_partial_move_ref_list_thm: heap_segment (gen_conf.gen_start,gen_conf.refs_start) s.heap = SOME(old,current,refs) /\ heap_length x <= heap_length s.heap /\ EVERY isRef x /\ - (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\ + (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\ heap_length s.heap * (dimindex (:α) DIV 8) < dimword (:α) /\ (word_heap (curr+bytes_in_word * n2w(heap_length old)) current conf * word_list pa xs * word_heap k x conf * frame) (fun2set (m,dm)) /\ @@ -3437,10 +3466,13 @@ Proof \\ fs[word_heap_def] \\ rfs[] \\ PairCases_on `b` \\ fs[word_el_def] - \\ pairarg_tac \\ fs[isRef_def] \\ rveq \\ fs[word_payload_def] + \\ pairarg_tac \\ fs [] + \\ pairarg_tac \\ fs [isRef_def] + \\ dxrule_then drule isMutTag_word_payload_IMP + \\ strip_tac \\ rveq \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR] \\ rveq \\ fs[word_list_def] - \\ `m k = Word(make_header conf 2w (LENGTH l))` by SEP_R_TAC + \\ `m k = Word(make_header conf (muttag_header b0) (LENGTH l))` by SEP_R_TAC \\ fs[theWord_def,el_length_def] \\ ntac 2 (pairarg_tac \\ fs[]) \\ drule(GEN_ALL word_gen_gc_partial_move_list_thm) @@ -3469,10 +3501,13 @@ Proof \\ fs[word_heap_APPEND,word_heap_def,word_el_def,el_length_def] \\ pairarg_tac \\ fs[] \\ fs[word_list_def] \\ fs[word_payload_def] \\ rveq \\ fs[] + \\ dxrule_then drule isMutTag_word_payload_IMP + \\ strip_tac \\ rveq + \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR] \\ fs[GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB,heap_length_def] \\ fs[AC STAR_ASSOC STAR_COMM] \\ fs[SEP_CLAUSES] - \\ fs[isRef_def] + \\ fs[isRef_def,isMutTag_def] QED val gc_move_ref_list_IMP = prove ( @@ -3522,17 +3557,18 @@ Proof Induct >- fs[gc_move_ref_list_def] >> Cases >> rpt strip_tac >> fs[gc_move_ref_list_def] - >> rveq >> fs[is_Ref_def] + >> rveq >> fs[is_Ref_def,isMutTag_def] >> ntac 2 (pairarg_tac >> fs[]) - >> rveq >> fs[is_Ref_def] + >> rveq >> fs[is_Ref_def,isMutTag_def] >> metis_tac[] QED Theorem EVERY_is_Ref_isRef: - (∀t r. f (t,r) ⇔ t = RefTag) ==> EVERY (is_Ref f) refs = EVERY isRef refs + (∀t r. f (t,r) ⇔ isMutTag t) ==> EVERY (is_Ref f) refs = EVERY isRef refs Proof - Induct_on `refs` >- fs[] >> Cases >> rpt strip_tac >> fs[isRef_def,is_Ref_def] - >> Cases_on `b` >> fs[isRef_def] + Induct_on `refs` >- fs[] >> Cases >> rpt strip_tac + >> fs[isRef_def,is_Ref_def,isMutTag_def] + >> Cases_on `b` >> fs[isRef_def,isMutTag_def] QED Definition ends_with_refs_def: @@ -3551,7 +3587,7 @@ Theorem word_gen_gc_partial_thm: ends_with_refs gen_conf.refs_start heap /\ heap_length heap * (dimindex (:α) DIV 8) < dimword (:α) /\ conf.len_size + 2 < dimindex (:α) /\ - (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\ + (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\ (word_gen_gc_partial conf (MAP (word_addr conf) roots,curr,new, bytes_in_word * n2w (heap_length heap),m,dm, bytes_in_word * n2w gen_conf.gen_start, @@ -3574,6 +3610,7 @@ Theorem word_gen_gc_partial_thm: heap_length s1.h1 + LENGTH xs1 + gen_conf.gen_start = gen_conf.refs_start /\ EVERY (is_Ref gen_conf.isRef) s1.r1 Proof + cheat (* rpt gen_tac \\ once_rewrite_tac [gen_gc_partialTheory.partial_gc_def] \\ fs [] \\ rpt (pairarg_tac \\ fs []) \\ strip_tac \\ fs [] \\ every_case_tac THEN1 (fs[] \\ rveq \\ fs[]) @@ -3677,7 +3714,7 @@ Proof \\ fs[AC STAR_ASSOC STAR_COMM] \\ qexists_tac `xs1''` \\ fs[] \\ drule partial_gc_move_ref_list_isRef - \\ fs[EVERY_is_Ref_isRef] + \\ fs[EVERY_is_Ref_isRef] *) QED Theorem word_gen_gc_partial_full_thm: @@ -3691,7 +3728,7 @@ Theorem word_gen_gc_partial_full_thm: gen_conf.refs_start <= heap_length heap /\ heap_length heap * (dimindex (:α) DIV 8) < dimword (:α) /\ conf.len_size + 2 < dimindex (:α) /\ - (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\ + (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\ (word_gen_gc_partial_full conf (MAP (word_addr conf) roots,curr,new, bytes_in_word * n2w (heap_length heap),m,dm, bytes_in_word * n2w gen_conf.gen_start, @@ -3918,7 +3955,7 @@ Proof fs [abs_ml_inv_def,unused_space_inv_def,gc_kind_inv_def] \\ strip_tac \\ fs [] \\ `EVERY isDataElement h2` by - (fs [EVERY_MEM] \\ Cases \\ strip_tac \\ res_tac \\ fs [isRef_def]) + (fs [EVERY_MEM] \\ Cases \\ strip_tac \\ res_tac \\ fs [isRef_def,isMutTag_def]) \\ fs [data_up_to_def] \\ Cases_on `sp + sp1 = 0` \\ fs [] THEN1 @@ -4626,7 +4663,7 @@ Proof \\ fs [heap_split_0] \\ fs [gen_state_ok_def,EVERY_MAP,gen_start_ok_def,heap_split_0] \\ fs [heap_split_def,el_length_def] \\ every_case_tac - \\ fs [isRef_def,heap_lookup_def]) + \\ fs [isRef_def,heap_lookup_def,isMutTag_def]) \\ CASE_TAC \\ fs [] \\ fs [heap_in_memory_store_def,heap_length_heap_expand,word_heap_heap_expand] \\ fs [glob_real_inv_def] @@ -6742,6 +6779,7 @@ Theorem soundness_size_of: IMAGE ($' tf) (domain s2) SUBSET set p2 /\ IMAGE ($' f) (domain refs DIFF domain r2) SUBSET set p2 Proof + cheat (* ho_match_mp_tac size_of_ind \\ rw [] THEN1 (fs [size_of_def] \\ rveq \\ simp [Once traverse_heap_cases] \\ qexists_tac `p1` \\ fs []) @@ -6890,7 +6928,7 @@ Proof \\ fs [] \\ qexists_tac `p2` \\ simp [] \\ once_rewrite_tac [traverse_heap_cases] \\ ntac 3 (disj2_tac) - \\ simp [] + \\ simp [] *) QED Theorem traverse_heap_reachable_set_mono: diff --git a/compiler/backend/proofs/word_gcFunctionsScript.sml b/compiler/backend/proofs/word_gcFunctionsScript.sml index 28142f664c..458e765409 100644 --- a/compiler/backend/proofs/word_gcFunctionsScript.sml +++ b/compiler/backend/proofs/word_gcFunctionsScript.sml @@ -307,7 +307,7 @@ Definition word_gen_gc_partial_full_def: End Definition is_ref_header_def: - is_ref_header (v:'a word) <=> ((v && 0b11100w) = 0b01000w) + is_ref_header (v:'a word) <=> ((v && 0b1100w) = 0b01000w) End Definition word_gen_gc_move_def: diff --git a/compiler/backend/stack_allocScript.sml b/compiler/backend/stack_allocScript.sml index 4a2db42550..e2b0f9f63a 100644 --- a/compiler/backend/stack_allocScript.sml +++ b/compiler/backend/stack_allocScript.sml @@ -148,9 +148,9 @@ Definition word_gen_gc_move_code_def: (* get len+1w *) right_shift_inst 1 (dimindex (:'a) - conf.len_size); add_1_inst 1; - const_inst 2 28w; + const_inst 2 0b1100w; and_inst 6 2; - If Equal 6 (Imm 8w) + If Equal 6 (Imm 8w) (* is_ref_header *) (list_Seq [ Set (Temp 0w) 3; Set (Temp 1w) 4; From 4f587ce3f7e5f847641ad23a1eb32f85fc77aca4 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Mon, 28 Jul 2025 03:52:42 +0200 Subject: [PATCH 028/112] Add Thunk case to size_of soundness thm --- .../proofs/data_to_word_gcProofScript.sml | 54 ++++++++++++++----- 1 file changed, 40 insertions(+), 14 deletions(-) diff --git a/compiler/backend/proofs/data_to_word_gcProofScript.sml b/compiler/backend/proofs/data_to_word_gcProofScript.sml index 005143f5c0..c7bebeeefe 100644 --- a/compiler/backend/proofs/data_to_word_gcProofScript.sml +++ b/compiler/backend/proofs/data_to_word_gcProofScript.sml @@ -3577,7 +3577,7 @@ Definition ends_with_refs_def: End Theorem word_gen_gc_partial_thm: - !m dm curr s1 pa1 m1 i1 frame c1 roots heap roots1 roots1' new. + ∀m dm curr s1 pa1 m1 i1 frame c1 roots heap roots1 roots1' new. (gen_gc_partial$partial_gc gen_conf (roots,heap) = (roots1,s1)) /\ s1.ok /\ heap_length heap <= dimword (:'a) DIV 2 ** shift_length conf /\ heap_length heap * (dimindex (:'a) DIV 8) < dimword (:'a) /\ @@ -3610,7 +3610,6 @@ Theorem word_gen_gc_partial_thm: heap_length s1.h1 + LENGTH xs1 + gen_conf.gen_start = gen_conf.refs_start /\ EVERY (is_Ref gen_conf.isRef) s1.r1 Proof - cheat (* rpt gen_tac \\ once_rewrite_tac [gen_gc_partialTheory.partial_gc_def] \\ fs [] \\ rpt (pairarg_tac \\ fs []) \\ strip_tac \\ fs [] \\ every_case_tac THEN1 (fs[] \\ rveq \\ fs[]) @@ -3714,7 +3713,7 @@ Proof \\ fs[AC STAR_ASSOC STAR_COMM] \\ qexists_tac `xs1''` \\ fs[] \\ drule partial_gc_move_ref_list_isRef - \\ fs[EVERY_is_Ref_isRef] *) + \\ fs[EVERY_is_Ref_isRef] QED Theorem word_gen_gc_partial_full_thm: @@ -6763,8 +6762,8 @@ Proof QED Theorem soundness_size_of: - !lims roots r1 s1 root_vars - (vars:'a word_loc heap_address list) n2 r2 s2 p1 refs. + ∀lims roots r1 s1 root_vars + (vars:'a word_loc heap_address list) n2 r2 s2 p1 refs. (∀n. reachable_refs root_vars refs n ⇒ bc_ref_inv c n refs (f,tf,heap,be)) /\ LIST_REL (λv x. v_inv c v (x,f,tf,heap)) root_vars vars /\ @@ -6774,12 +6773,11 @@ Theorem soundness_size_of: FDOM f SUBSET domain refs /\ subspt r1 refs /\ (lims.arch_64_bit ⇔ dimindex (:α) = 64) /\ size_of lims roots r1 s1 = (n2,r2,s2) ==> - ?p2. SUM (MAP (lookup_len heap) p2) <= n2 + SUM (MAP (lookup_len heap) p1) /\ + ∃p2. SUM (MAP (lookup_len heap) p2) <= n2 + SUM (MAP (lookup_len heap) p1) /\ traverse_heap heap p1 vars p2 /\ subspt r2 refs /\ IMAGE ($' tf) (domain s2) SUBSET set p2 /\ IMAGE ($' f) (domain refs DIFF domain r2) SUBSET set p2 Proof - cheat (* ho_match_mp_tac size_of_ind \\ rw [] THEN1 (fs [size_of_def] \\ rveq \\ simp [Once traverse_heap_cases] \\ qexists_tac `p1` \\ fs []) @@ -6810,7 +6808,7 @@ Proof \\ asm_exists_tac \\ fs [] \\ asm_exists_tac \\ fs [] \\ fs [EXTENSION] \\ metis_tac []) - THEN1 (* Word case *) + >~ [‘Word64’] >- (fs [size_of_def] \\ rveq \\ fs [v_inv_def] \\ rveq \\ fs [Word64Rep_def] \\ every_case_tac \\ fs [] @@ -6819,7 +6817,7 @@ Proof \\ fs [SUBSET_DEF] \\ once_rewrite_tac [traverse_heap_cases] \\ fs [] \\ once_rewrite_tac [traverse_heap_cases] \\ fs []) - THEN1 (* Number case *) + >~ [‘Number’] >- (fs [] \\ rveq \\ fs [] \\ fs [v_inv_def] \\ Cases_on `small_int (:α) i` \\ fs [] \\ rveq \\ fs [] THEN1 @@ -6835,12 +6833,12 @@ Proof \\ fs [SUBSET_DEF] \\ once_rewrite_tac [traverse_heap_cases] \\ fs [] \\ once_rewrite_tac [traverse_heap_cases] \\ fs []) - THEN1 (* CodePtr case *) + >~ [‘CodePtr’] >- (fs [size_of_def] \\ rveq \\ fs [v_inv_def] \\ rveq \\ fs [] \\ once_rewrite_tac [traverse_heap_cases] \\ fs [] \\ qexists_tac `p1` \\ fs []) - THEN1 (* RefPtr case *) + >~ [‘RefPtr r1 r’] >- (fs [size_of_def] \\ rveq \\ fs [v_inv_def] \\ rveq \\ fs [CaseEq"option"] \\ rveq \\ fs [] THEN1 @@ -6848,8 +6846,9 @@ Proof THEN1 (once_rewrite_tac [traverse_heap_cases]\\ fs []) \\ fs [SUBSET_DEF] \\ first_x_assum match_mp_tac \\ qexists_tac `r` \\ fs [] \\ fs [domain_lookup]) + \\ rename [‘lookup r refs1 = SOME v’] \\ reverse (Cases_on `v`) \\ fs [] - THEN1 + >~ [‘ByteArray b l’] >- (rveq \\ fs [] \\ fs [] \\ first_x_assum (qspec_then `r` mp_tac) \\ (impl_tac THEN1 fs [reachable_refs_def,get_refs_def]) @@ -6863,6 +6862,33 @@ Proof \\ once_rewrite_tac [traverse_heap_cases] \\ fs [] \\ once_rewrite_tac [traverse_heap_cases] \\ fs [] \\ fs [SUBSET_DEF,PULL_EXISTS] \\ metis_tac []) + >~ [‘Thunk t a’] >- + (pairarg_tac \\ gvs [PULL_EXISTS] + \\ first_assum (qspec_then `r` mp_tac) + \\ impl_tac THEN1 fs [reachable_refs_def,get_refs_def] + \\ simp [bc_ref_inv_def,FLOOKUP_DEF] + \\ CASE_TAC \\ gvs [] + \\ fs [subspt_lookup] + \\ first_assum drule + \\ strip_tac \\ fs [] \\ rveq \\ fs [] + \\ strip_tac \\ fs [] + \\ last_x_assum $ drule_at $ Pos $ el 2 + \\ disch_then $ qspecl_then [`f ' r :: p1`,`refs`] mp_tac + \\ impl_tac THEN1 + (fs [] \\ fs [lookup_delete,SUBSET_DEF,PULL_EXISTS] + \\ simp [SF DNF_ss] + \\ rpt strip_tac + \\ first_x_assum match_mp_tac + \\ fs [reachable_refs_def,get_refs_def] + \\ once_rewrite_tac [RTC_CASES1] \\ disj2_tac + \\ rename [`RTC _ r5 r6`] \\ qexists_tac `r5` \\ fs [] + \\ simp [ref_edge_def,get_refs_def,MEM_FLAT,MEM_MAP,PULL_EXISTS] + \\ asm_exists_tac \\ fs []) + \\ strip_tac \\ qexists_tac `p2` \\ fs [] + \\ rfs [lookup_len_def,el_length_def,ThunkBlock_def] + \\ once_rewrite_tac [traverse_heap_cases] + \\ rpt disj2_tac \\ fs []) + \\ rename [‘ValueArray l’] \\ pop_assum mp_tac \\ pairarg_tac \\ fs [] \\ rw [] \\ first_assum (qspec_then `r` mp_tac) @@ -6887,7 +6913,7 @@ Proof \\ imp_res_tac LIST_REL_LENGTH \\ fs [] \\ once_rewrite_tac [traverse_heap_cases] \\ rpt disj2_tac \\ fs []) - THEN1 (* empty Block *) + >~ [‘Block ts tag []’] >- (fs [size_of_def] \\ rveq \\ fs [v_inv_def] \\ rveq \\ fs [] \\ once_rewrite_tac [traverse_heap_cases] \\ fs [] @@ -6928,7 +6954,7 @@ Proof \\ fs [] \\ qexists_tac `p2` \\ simp [] \\ once_rewrite_tac [traverse_heap_cases] \\ ntac 3 (disj2_tac) - \\ simp [] *) + \\ simp [] QED Theorem traverse_heap_reachable_set_mono: From 57433d50778e83456f4f95f3109a62595dd95c98 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Tue, 29 Jul 2025 02:23:01 +0200 Subject: [PATCH 029/112] Fix up tail end of data_to_word_assignProof --- .../proofs/data_to_word_assignProofScript.sml | 27 ++++++++++++------- 1 file changed, 18 insertions(+), 9 deletions(-) diff --git a/compiler/backend/proofs/data_to_word_assignProofScript.sml b/compiler/backend/proofs/data_to_word_assignProofScript.sml index 9fe4b91235..4bc4335186 100644 --- a/compiler/backend/proofs/data_to_word_assignProofScript.sml +++ b/compiler/backend/proofs/data_to_word_assignProofScript.sml @@ -4698,13 +4698,13 @@ Proof QED Theorem assign_AllocThunk: - op = ThunkOp (AllocThunk ev) ==> ^assign_thm_goal + (∃ev. op = ThunkOp (AllocThunk ev)) ==> ^assign_thm_goal Proof cheat QED Theorem assign_UpdateThunk: - op = ThunkOp (UpdateThunk ev) ==> ^assign_thm_goal + (∃ev. op = ThunkOp (UpdateThunk ev)) ==> ^assign_thm_goal Proof cheat QED @@ -13969,13 +13969,22 @@ Proof \\ Cases_on`op = MemOp (CopyByte T)` >- ( fs[do_app_def,do_space_def,do_app_aux_def] \\ every_case_tac \\ fs[] ) - \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] - \\ qsuff_tac `assign c n l dest op args names_opt = (GiveUp,l)` \\ fs [] - \\ `?f. f () = op` by (qexists_tac `K op` \\ fs []) (* here for debugging only *) - \\ cheat (* - \\ cases_on_op `op` \\ fs [assign_def] - \\ rpt (PURE_CASE_TAC \\ fs []) - \\ qhdtm_x_assum`do_app`mp_tac \\ EVAL_TAC *) + \\ Cases_on ‘∃i. op = IntOp i’ + >- (fs [] \\ fs [] \\ gvs [] \\ Cases_on ‘i’ \\ gvs []) + \\ Cases_on ‘∃i. op = GlobOp i’ + >- (fs [] \\ fs [] \\ gvs [] \\ Cases_on ‘i’ \\ gvs []) + \\ Cases_on ‘∃i. op = MemOp i’ + >- (fs [] \\ fs [] \\ gvs [] \\ Cases_on ‘i’ \\ gvs [] + \\ qhdtm_x_assum`do_app`mp_tac \\ EVAL_TAC) + \\ Cases_on ‘∃i. op = BlockOp i’ + >- (fs [] \\ fs [] \\ gvs [] \\ Cases_on ‘i’ \\ gvs [] + \\ qhdtm_x_assum`do_app`mp_tac \\ EVAL_TAC) + \\ Cases_on ‘∃i. op = WordOp i’ + >- (fs [] \\ fs [] \\ gvs [] \\ Cases_on ‘i’ \\ gvs [] \\ Cases_on ‘w’ \\ gvs []) + \\ Cases_on ‘∃i. op = ThunkOp i’ + >- (fs [] \\ fs [] \\ gvs [] \\ Cases_on ‘i’ \\ gvs [] + \\ qhdtm_x_assum`do_app`mp_tac \\ EVAL_TAC) + \\ Cases_on ‘op’ \\ gvs [] QED val _ = export_theory(); From 8bc1a476d24025afd0dbbd1d9eeb138b87ae9618 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Tue, 29 Jul 2025 16:35:09 +0300 Subject: [PATCH 030/112] Prove some cheats in `data_to_word_memoryProof` --- .../proofs/data_to_word_memoryProofScript.sml | 151 ++++++++++++------ 1 file changed, 100 insertions(+), 51 deletions(-) diff --git a/compiler/backend/proofs/data_to_word_memoryProofScript.sml b/compiler/backend/proofs/data_to_word_memoryProofScript.sml index 1569a76f7c..e83bae1d91 100644 --- a/compiler/backend/proofs/data_to_word_memoryProofScript.sml +++ b/compiler/backend/proofs/data_to_word_memoryProofScript.sml @@ -610,8 +610,11 @@ Proof \\ rw [] \\ qexists_tac `ws` \\ fs []) >~ [‘lookup n refs = SOME (Thunk ev v)’] >- (fs [ThunkBlock_def] - \\ res_tac \\ fs [] - \\ cheat) + \\ res_tac \\ gvs [] + \\ disch_then $ drule_at Any \\ gvs [] \\ rw [] + \\ goal_assum $ drule_at Any \\ gvs [] + \\ first_x_assum $ drule_at (Pat `heap_lookup _ _ = SOME _`) \\ rw [] + \\ Cases_on `z` \\ gvs [ADDR_MAP_def, ADDR_APPLY_def]) \\ res_tac \\ full_simp_tac (srw_ss()) [LENGTH_ADDR_MAP,EVERY2_ADDR_MAP] \\ rpt strip_tac \\ qpat_x_assum `EVERY2 qqq zs l` MP_TAC \\ match_mp_tac EVERY2_IMP_EVERY2 \\ simp_tac std_ss [] \\ rpt strip_tac @@ -2206,18 +2209,23 @@ Theorem v_in_all_vs: x ∈ all_vs refs stack ∧ MEM y (v_all_vs [x]) ⇒ y ∈ all_vs refs stack Proof - cheat (* rw [all_vs_def] - >- (disj1_tac + >- (ntac 2 disj1_tac \\ cases_on `x` \\ fs [v_all_vs_def] \\ map_every qexists_tac [`n`,`l`] \\ rw [] \\ drule_then ASSUME_TAC v_all_vs_MEM \\ fs []) + >- (disj1_tac \\ disj2_tac + \\ cases_on `x` \\ fs [v_all_vs_def] + \\ map_every qexists_tac [`n`,`ev`,`x'`] + \\ rw [] + \\ drule_then ASSUME_TAC v_all_vs_MEM + \\ fs []) >- (disj2_tac \\ cases_on `x` \\ fs [v_all_vs_def] \\ drule_then ASSUME_TAC v_all_vs_MEM - \\ fs []) *) + \\ fs []) QED Theorem v_all_vs_MEM2: @@ -2601,7 +2609,6 @@ Theorem word64_alt_thm: (Pointer a (Word 0w)::roots,heap2, be,a + len + 1,sp - len - 1,sp1,gens) limit ts Proof - cheat (* rw[abs_ml_inv_def] \\ qpat_abbrev_tac`wr = DataElement _ _ _` \\ `el_length wr = len + 1` @@ -2690,23 +2697,39 @@ Proof \\ BasicProvers.TOP_CASE_TAC \\ fs[] \\ BasicProvers.TOP_CASE_TAC \\ fs[] \\ BasicProvers.TOP_CASE_TAC \\ fs[] \\ rw[] - \\ fs[RefBlock_def,Bytes_def] - \\ imp_res_tac heap_store_rel_lemma - \\ fs[] - \\ TRY (qexists_tac`ws'` \\ simp[]) - \\ match_mp_tac EVERY2_MEM_MONO - \\ first_assum(part_match_exists_tac(last o strip_conj) o concl) - \\ simp[FORALL_PROD] \\ rw[] - \\ ho_match_mp_tac v_inv_tf_restrict - \\ conj_tac - >- (match_mp_tac v_inv_SUBMAP \\ simp[]) - >- (rw [] \\ ho_match_mp_tac MEM_in_all_ts - \\ qexists_tac `p_2` \\ rw [] - \\ rw [all_vs_def] \\ disj1_tac - \\ map_every qexists_tac [`n`,`l`] \\ rw [] - \\ ho_match_mp_tac MEM_v_all_vs - \\ drule MEM_ZIP2 \\ rw [] - \\ rw [EL_MEM]) *) + >- ( + fs[RefBlock_def] + \\ imp_res_tac heap_store_rel_lemma + \\ fs[] + \\ match_mp_tac EVERY2_MEM_MONO + \\ first_assum(part_match_exists_tac(last o strip_conj) o concl) + \\ simp[FORALL_PROD] \\ rw[] + \\ ho_match_mp_tac v_inv_tf_restrict + \\ conj_tac + >- (match_mp_tac v_inv_SUBMAP \\ simp[]) + \\ rw [] \\ ho_match_mp_tac MEM_in_all_ts + \\ qexists_tac `p_2` \\ rw [] + \\ rw [all_vs_def] \\ ntac 2 disj1_tac + \\ map_every qexists_tac [`n`,`l`] \\ rw [] + \\ ho_match_mp_tac MEM_v_all_vs + \\ drule MEM_ZIP2 \\ rw [] + \\ rw [EL_MEM]) + >- ( + fs[Bytes_def] + \\ imp_res_tac heap_store_rel_lemma) + >- ( + fs[ThunkBlock_def] + \\ imp_res_tac heap_store_rel_lemma + \\ fs[] + \\ ho_match_mp_tac v_inv_tf_restrict + \\ conj_tac + >- (match_mp_tac v_inv_SUBMAP \\ simp[]) + \\ rw [] \\ ho_match_mp_tac MEM_in_all_ts + \\ first_x_assum $ irule_at Any + \\ rw [all_vs_def] \\ disj1_tac \\ disj2_tac + \\ goal_assum drule + \\ ho_match_mp_tac MEM_v_all_vs + \\ rw [EL_MEM]) QED (* bignum *) @@ -2721,7 +2744,6 @@ Theorem bignum_alt_thm: abs_ml_inv conf (Number i::stack) refs (Pointer a (Word (0w:α word))::roots,heap2,be,a+len+1,sp-len-1,sp1,gens) limit ts Proof - cheat (* rw[abs_ml_inv_def] \\ qmatch_assum_abbrev_tac`br = DataElement _ _ _` \\ `el_length br = len + 1` by @@ -2756,7 +2778,7 @@ Proof \\ rfs[] \\ fs[bc_stack_ref_inv_def] \\ conj_tac THEN1 - (`tag <> RefTag` by + (`tag ≠ RefTag ∧ ∀ev. tag ≠ ThunkTag ev` by (CCONTR_TAC \\ qpat_x_assum `Abbrev _` mp_tac \\ fs [Bignum_def,markerTheory.Abbrev_def] \\ pairarg_tac \\ fs [] \\ NO_TAC) @@ -2812,23 +2834,39 @@ Proof \\ BasicProvers.TOP_CASE_TAC \\ fs[] \\ BasicProvers.TOP_CASE_TAC \\ fs[] \\ BasicProvers.TOP_CASE_TAC \\ fs[] \\ rw[] - \\ fs[RefBlock_def,Bytes_def] - \\ imp_res_tac heap_store_rel_lemma - \\ fs[] - \\ TRY (qexists_tac`ws'` \\ simp[]) - \\ match_mp_tac EVERY2_MEM_MONO - \\ first_assum(part_match_exists_tac(last o strip_conj) o concl) - \\ simp[FORALL_PROD] \\ rw[] - \\ ho_match_mp_tac v_inv_tf_restrict - \\ conj_tac - >- (match_mp_tac v_inv_SUBMAP \\ simp[]) - >- (rw [] \\ ho_match_mp_tac MEM_in_all_ts - \\ qexists_tac `p_2` \\ rw [] - \\ rw [all_vs_def] \\ disj1_tac - \\ map_every qexists_tac [`n`,`l`] \\ rw [] - \\ ho_match_mp_tac MEM_v_all_vs - \\ drule MEM_ZIP2 \\ rw [] - \\ rw [EL_MEM]) *) + >- ( + fs[RefBlock_def] + \\ imp_res_tac heap_store_rel_lemma + \\ fs[] + \\ match_mp_tac EVERY2_MEM_MONO + \\ first_assum(part_match_exists_tac(last o strip_conj) o concl) + \\ simp[FORALL_PROD] \\ rw[] + \\ ho_match_mp_tac v_inv_tf_restrict + \\ conj_tac + >- (match_mp_tac v_inv_SUBMAP \\ simp[]) + \\ rw [] \\ ho_match_mp_tac MEM_in_all_ts + \\ qexists_tac `p_2` \\ rw [] + \\ rw [all_vs_def] \\ ntac 2 disj1_tac + \\ map_every qexists_tac [`n`,`l`] \\ rw [] + \\ ho_match_mp_tac MEM_v_all_vs + \\ drule MEM_ZIP2 \\ rw [] + \\ rw [EL_MEM]) + >- ( + fs[Bytes_def] + \\ imp_res_tac heap_store_rel_lemma) + >- ( + fs[ThunkBlock_def] + \\ imp_res_tac heap_store_rel_lemma + \\ fs[] + \\ ho_match_mp_tac v_inv_tf_restrict + \\ conj_tac + >- (match_mp_tac v_inv_SUBMAP \\ simp[]) + \\ rw [] \\ ho_match_mp_tac MEM_in_all_ts + \\ first_x_assum $ irule_at Any + \\ rw [all_vs_def] \\ disj1_tac \\ disj2_tac + \\ goal_assum drule + \\ ho_match_mp_tac MEM_v_all_vs + \\ rw [EL_MEM]) QED (* update ref *) @@ -4030,7 +4068,6 @@ Theorem new_byte_alt_thm: (Pointer a (Word 0w)::roots,heap2,be,a + ws + 1, sp - (ws + 1),sp1,gens) limit ts Proof - cheat (* simp_tac std_ss [abs_ml_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def] \\ imp_res_tac EVERY2_APPEND_IMP_APPEND @@ -4145,15 +4182,16 @@ Proof \\ TOP_CASE_TAC \\ fs [] \\ rveq \\ fs [] \\ TOP_CASE_TAC \\ fs [] \\ rveq \\ fs [] \\ fs [Bytes_def,isDataElement_def,LET_THM,heap_store_rel_def, - isSomeDataElement_def,PULL_EXISTS,RefBlock_def,lookup_NONE_domain] \\ rw [] + isSomeDataElement_def,PULL_EXISTS,RefBlock_def,lookup_NONE_domain, + ThunkBlock_def] \\ rw [] \\ res_tac \\ qpat_x_assum `EVERY2 PPP zs l` MP_TAC \\ fs [heap_store_rel_def,isSomeDataElement_def,PULL_EXISTS] - \\ match_mp_tac EVERY2_IMP_EVERY2 + \\ TRY (match_mp_tac EVERY2_IMP_EVERY2) \\ full_simp_tac std_ss [] \\ simp_tac (srw_ss()) [] \\ rpt strip_tac \\ match_mp_tac v_inv_SUBMAP \\ fs [] - \\ fs [heap_store_rel_def,isSomeDataElement_def,PULL_EXISTS] *) + \\ fs [heap_store_rel_def,isSomeDataElement_def,PULL_EXISTS] QED (* equality *) @@ -9908,7 +9946,6 @@ Theorem word_eq_thm0: (b <=> (res = 1w)) /\ l <= l1 + (LENGTH v1 + SUM (MAP vb_size v1)) * dimword (:'a)) Proof - cheat (* ho_match_mp_tac do_eq_ind \\ rpt conj_tac \\ once_rewrite_tac [do_eq_def] \\ simp [] THEN1 (* do_eq Numbers *) @@ -10023,9 +10060,11 @@ Proof every_case_tac \\ fs[] \\ drule (GEN_ALL memory_rel_ValueArray_IMP) \\ fs[] \\ drule (GEN_ALL memory_rel_ByteArray_IMP) \\ fs[] + \\ drule (GEN_ALL memory_rel_Thunk_IMP) \\ fs[] \\ qhdtm_x_assum`memory_rel`kall_tac \\ drule (GEN_ALL memory_rel_ValueArray_IMP) \\ fs[] \\ drule (GEN_ALL memory_rel_ByteArray_IMP) \\ fs[] + \\ drule (GEN_ALL memory_rel_Thunk_IMP) \\ fs[] \\ strip_tac \\ fs[]) \\ fs[] \\ clean_tac \\ fs[] \\ clean_tac \\ rpt_drule memory_rel_ByteArray_words_IMP @@ -10200,7 +10239,7 @@ Proof (CONJUNCT2 word_eq_min_max_clock) \\ PURE_ONCE_REWRITE_TAC[MAX_COMM] \\ fs[ETA_THM] - \\ fs[LEFT_ADD_DISTRIB] *) + \\ fs[LEFT_ADD_DISTRIB] QED Theorem word_eq_thm: @@ -12151,7 +12190,6 @@ Theorem cons_multi_thm: ++ heap2, be, a + heap_length Allocd, sp - heap_length Allocd, sp1, gens) limit (ts + LENGTH xs) Proof - cheat (* rw [abs_ml_inv_def] \\ qpat_x_assum `bc_stack_ref_inv _ _ _ _ _` mp_tac \\ simp [Once bc_stack_ref_inv_def] \\ strip_tac @@ -12405,7 +12443,7 @@ Proof (fs [reachable_refs_def] \\ rveq \\ metis_tac [list_to_v_get_refs]) \\ simp [bc_ref_inv_def] \\ fs [] - \\ fs [RefBlock_def, Bytes_def] + \\ fs [RefBlock_def, Bytes_def, ThunkBlock_def] \\ ntac 3 TOP_CASE_TAC \\ fs [] \\ unlength_tac [heap_lookup_APPEND, heap_length_APPEND] \\ `0 < heap_length Allocd /\ heap_length Allocd <= sp + sp1` by fs [] @@ -12429,6 +12467,17 @@ Proof \\ NO_TAC) \\ TRY (first_x_assum drule \\ rw []) + \\ unlength_tac [] + \\ TRY + (qmatch_goalsub_abbrev_tac `v_inv _ _ (_,ab1,ab2)` + \\ `LIST_REL (λz y. v_inv conf y (z,ab1,ab2)) [z] [a]` suffices_by gvs [] + \\ unabbrev_all_tac + \\ first_x_assum irule \\ gvs [] + \\ pop_assum (mp_then Any ho_match_mp_tac (GEN_ALL v_inv_SUBMAP)) + \\ rw [heap_store_rel_def] + \\ ho_match_mp_tac bind_each_SUBMAP + \\ fs [SUBSET_DEF] + \\ NO_TAC) \\ unlength_tac []) \\ reverse conj_tac >- @@ -12456,7 +12505,7 @@ Proof \\ qpat_x_assum `LENGTH xs = _` (assume_tac o GSYM) \\ rw [] \\ match_mp_tac (Q.INST [`sp`|->`sp+sp1`] (SPEC_ALL v_inv_list_to_v)) - \\ unlength_tac [heap_expand_def] *) + \\ unlength_tac [heap_expand_def] QED Theorem memory_rel_append: From c8a73424df20c1bb8fe60128433402f581b5af91 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 31 Jul 2025 03:19:50 +0300 Subject: [PATCH 031/112] - Fixed `bvl_handle` - Added `AllocThunk` and `UpdateThunk` to `data_to_word` - Proved various cheats in `data_to_word_memoryProof` - Proved `AllocThunk` in `data_to_word_assignProof` --- compiler/backend/bvl_handleScript.sml | 10 +- compiler/backend/data_to_wordScript.sml | 43 +++++ .../backend/proofs/bvl_handleProofScript.sml | 6 +- .../proofs/data_to_word_assignProofScript.sml | 95 ++++++++++- .../proofs/data_to_word_memoryProofScript.sml | 148 +++++++++++++----- 5 files changed, 255 insertions(+), 47 deletions(-) diff --git a/compiler/backend/bvl_handleScript.sml b/compiler/backend/bvl_handleScript.sml index 393401205d..8fc948bf83 100644 --- a/compiler/backend/bvl_handleScript.sml +++ b/compiler/backend/bvl_handleScript.sml @@ -191,7 +191,10 @@ Definition compile_def: OptionalLetLet (Raise (HD dx)) n lx (s1+1) l F) /\ (compile l n [Op op xs] = let (ys,lx,s1,nr1) = compile l n xs in - OptionalLetLet (Op op ys) n lx (s1+1) l nr1) /\ + if op = ThunkOp ForceThunk then + ([Op op ys],lx,s1+1,F) + else + OptionalLetLet (Op op ys) n lx (s1+1) l nr1) /\ (compile l n [Tick x] = let (y,lx,s1,nr1) = compile l n [x] in ([Tick (HD y)],lx,s1,nr1)) /\ @@ -234,7 +237,10 @@ Definition compile_sing_def: OptionalLetLet_sing (Raise dx) n lx (s1+1) l F) /\ (compile_sing l n (Op op xs) = let (ys,lx,s1,nr1) = compile_list l n xs in - OptionalLetLet_sing (Op op ys) n lx (s1+1) l nr1) /\ + if op = ThunkOp ForceThunk then + (Op op ys,lx,s1+1,F) + else + OptionalLetLet_sing (Op op ys) n lx (s1+1) l nr1) /\ (compile_sing l n (Tick x) = let (y,lx,s1,nr1) = compile_sing l n x in (Tick y,lx,s1,nr1)) /\ diff --git a/compiler/backend/data_to_wordScript.sml b/compiler/backend/data_to_wordScript.sml index 3dd9395a23..666688af4e 100644 --- a/compiler/backend/data_to_wordScript.sml +++ b/compiler/backend/data_to_wordScript.sml @@ -1217,6 +1217,25 @@ val def = assign_Define ` (Assign (adjust_var dest) Unit),l) : 'a wordLang$prog # num`; +val def = assign_Define ` + assign_UpdateThunk ev (c:data_to_word$config) (l:num) (dest:num) v1 v2 = + (dtcase ev of + | NotEvaluated => + (Seq (Store (Op Add [real_addr c (adjust_var v1); + Const bytes_in_word]) + (adjust_var v2)) + (Assign (adjust_var dest) Unit),l) + | Evaluated => + (dtcase encode_header c (8 + 6) 1 of + | NONE => (GiveUp,l) + | SOME (header:'a word) => (list_Seq + [Assign 1 (real_addr c (adjust_var v1)); + Assign 3 (Const header); + Store (Var 1) 3; + Store (Op Add [Var 1; Const bytes_in_word]) (adjust_var v2); + Assign (adjust_var dest) Unit],l))) + : 'a wordLang$prog # num`; + val def = assign_Define ` assign_UpdateByte (c:data_to_word$config) (l:num) (dest:num) v1 v2 v3 = (list_Seq [ @@ -1488,6 +1507,28 @@ val def = assign_Define ` Const 1w])],l)) : 'a wordLang$prog # num`; +val def = assign_Define ` + assign_AllocThunk (ev : thunk_mode) (c:data_to_word$config) (secn:num) + (l:num) (dest:num) (names:num_set option) arg = + (let tag = (dtcase ev of + | Evaluated => 8 + 6 + | NotEvaluated => 0 + 6) in + dtcase encode_header c tag 1 of + | NONE => (GiveUp,l) + | SOME (header:'a word) => (list_Seq + [Set TriggerGC (Op Sub [Lookup TriggerGC; + Const (bytes_in_word * 2w)]); + Assign 1 (Op Sub [Lookup EndOfHeap; + Const (bytes_in_word * 2w)]); + Set EndOfHeap (Var 1); + Assign 3 (Const header); + StoreEach 1 [3; adjust_var arg] 0w; + Assign (adjust_var dest) + (Op Or [Shift Lsl (Op Sub [Var 1; Lookup CurrHeap]) + (shift_length c − shift (:'a)); + Const 1w])],l)) + : 'a wordLang$prog # num`; + val def = assign_Define ` assign_RefByte (c:data_to_word$config) (secn:num) (l:num) (dest:num) (names:num_set option) immutable v1 v2 = @@ -2331,6 +2372,8 @@ Definition assign_def: | BlockOp (Build parts) => assign_Build c secn l dest names parts | BlockOp (ConsExtend tag) => assign_ConsExtend c secn l dest names tag args | MemOp Ref => assign_Ref c secn l dest names args + | ThunkOp (AllocThunk ev) => arg1 args (assign_AllocThunk ev c secn l dest names) (Skip,l) + | ThunkOp (UpdateThunk ev) => arg2 args (assign_UpdateThunk ev c l dest) (Skip,l) | MemOp (RefByte imm) => arg2 args (assign_RefByte c secn l dest names imm) (Skip,l) | MemOp XorByte => arg2 args (assign_XorByte c secn l dest names) (Skip,l) | Label n => (LocValue (adjust_var dest) n,l) diff --git a/compiler/backend/proofs/bvl_handleProofScript.sml b/compiler/backend/proofs/bvl_handleProofScript.sml index 79834ed2e8..82abdabdb5 100644 --- a/compiler/backend/proofs/bvl_handleProofScript.sml +++ b/compiler/backend/proofs/bvl_handleProofScript.sml @@ -436,12 +436,16 @@ Theorem compile_correct = Q.prove(` \\ Cases \\ fs [ADD1]) \\ res_tac \\ fs []) THEN1 (* Op *) (fs [env_rel_mk_Union] \\ rpt gen_tac \\ strip_tac + \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs [] + >- ( + gvs [AllCaseEqs()] + \\ rpt strip_tac + \\ simp [evaluate_def] \\ gvs []) \\ drule (GEN_ALL OptionalLetLet_IMP) \\ strip_tac \\ pop_assum match_mp_tac \\ drule (GEN_ALL OptionalLetLet_limit) \\ imp_res_tac OptionalLetLet_nr \\ fs [env_rel_mk_Union] \\ strip_tac - \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs [] >- cheat \\ Cases_on `evaluate (xs,env,s)` \\ Cases_on `q` \\ fs [] \\ rw [] \\ res_tac \\ fs [evaluate_def] \\ every_case_tac \\ fs [] \\ rveq \\ fs [] diff --git a/compiler/backend/proofs/data_to_word_assignProofScript.sml b/compiler/backend/proofs/data_to_word_assignProofScript.sml index f94f45f64a..ca8cae7ec9 100644 --- a/compiler/backend/proofs/data_to_word_assignProofScript.sml +++ b/compiler/backend/proofs/data_to_word_assignProofScript.sml @@ -2102,12 +2102,11 @@ Proof QED fun cases_on_op q = Cases_on q >| - map (MAP_EVERY Cases_on) [[], [], [], [], [`b`], [`g`], [`m`], []]; + map (MAP_EVERY Cases_on) [[], [], [], [], [`b`], [`g`], [`m`], [], [`t`]]; Theorem do_app_aux_safe_for_space_mono: (do_app_aux op xs s = Rval (r,s1)) /\ s1.safe_for_space ==> s.safe_for_space Proof - cheat (* cases_on_op `op` \\ fs [do_app_aux_def,list_case_eq,option_case_eq,v_case_eq,AllCaseEqs(), bool_case_eq,ffiTheory.call_FFI_def,do_app_def,do_space_def, @@ -2117,7 +2116,7 @@ Proof pair_case_eq,consume_space_def,dataLangTheory.op_space_reset_def,data_spaceTheory.op_space_req_def] \\ rw [] \\ fs [state_component_equality] \\ rw [] \\ rpt (pairarg_tac \\ fs []) - \\ EVERY_CASE_TAC \\ fs [] *) + \\ EVERY_CASE_TAC \\ fs [] QED Theorem do_app_safe_for_space_allowed_op: @@ -4941,10 +4940,98 @@ Proof \\ drule ALOOKUP_MEM \\ simp [] QED +Theorem do_app_AllocThunk: + do_app (ThunkOp (AllocThunk m)) [v] x = + case consume_space (1 + 1) x of + NONE => Rerr (Rabort Rtype_error) + | SOME s1 => + Rval + (RefPtr F (LEAST ptr. ptr ∉ domain s1.refs), + s1 with <| + refs := insert (LEAST ptr. ptr ∉ domain s1.refs) (Thunk m v) s1.refs; + safe_for_space := ( + do_stack + (ThunkOp (AllocThunk m)) [v] + (do_lim_safe s1 (ThunkOp (AllocThunk m)) [v])).safe_for_space; + stack_max := ( + do_stack + (ThunkOp (AllocThunk m)) [v] + (do_lim_safe s1 (ThunkOp (AllocThunk m)) [v])).stack_max |>) +Proof + gvs [do_app, consume_space_def] +QED + Theorem assign_AllocThunk: (∃ev. op = ThunkOp (AllocThunk ev)) ==> ^assign_thm_goal Proof - cheat + rpt strip_tac \\ drule0 (evaluate_GiveUp2 |> GEN_ALL) \\ rw [] \\ fs [] + \\ `t.termdep <> 0` by fs[] + \\ asm_rewrite_tac [] \\ pop_assum kall_tac + \\ rpt_drule0 state_rel_cut_IMP + \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac + \\ imp_res_tac get_vars_IMP_LENGTH \\ fs [] + \\ fs [assign_def] \\ fs [do_app_AllocThunk] \\ fs[do_app] + \\ Cases_on `consume_space (LENGTH vals + 1) x` \\ fs [] \\ rveq + \\ Cases_on `vals` \\ gvs [] + \\ Cases_on `t'` \\ gvs [] + \\ gvs [dataLangTheory.op_requires_names_def, + dataLangTheory.op_space_reset_def] + \\ imp_res_tac get_vars_IMP_LENGTH \\ fs [] \\ clean_tac + \\ fs [consume_space_def] \\ clean_tac + \\ imp_res_tac state_rel_get_vars_IMP + \\ Cases_on `ws` \\ gvs [] + \\ Cases_on `args` \\ gvs [] + \\ simp [allowed_op_def] + \\ TOP_CASE_TAC \\ fs [] + >- ( + conj_tac + >- ( + fs [state_rel_def] + \\ rw [option_le_max_right] + \\ metis_tac[option_le_trans]) + \\ fs[encode_header_def] + \\ fs[encode_header_def, state_rel_def, good_dimindex_def, limits_inv_def, + dimword_def, memory_rel_def, heap_in_memory_store_def, + consume_space_def, arch_size_def] + \\ rfs[NOT_LESS] + \\ Cases_on `ev` \\ gvs []) + \\ simp [state_rel_thm] \\ eval_tac + \\ fs [state_rel_thm] \\ eval_tac + \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] + \\ drule0 (memory_rel_get_vars_IMP |> GEN_ALL) + \\ disch_then drule0 \\ fs [NOT_LESS,DECIDE ``n + 1 <= m <=> n < m:num``] + \\ strip_tac + \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] + \\ qabbrev_tac `new = LEAST ptr. ptr ∉ domain x.refs` + \\ `new ∉ domain x.refs` by metis_tac [LEAST_NOTIN_spt_DOMAIN] + \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] + \\ rpt_drule0 memory_rel_AllocThunk \\ strip_tac + \\ fs [list_Seq_def] \\ eval_tac + \\ fs [wordSemTheory.set_store_def,FLOOKUP_UPDATE] + \\ qpat_abbrev_tac `t5 = t with <| locals := _ ; store := _ |>` + \\ pairarg_tac \\ fs [] + \\ `t.memory = t5.memory /\ t.mdomain = t5.mdomain` by + (unabbrev_all_tac \\ fs []) \\ fs [] + \\ ntac 2 (pop_assum kall_tac) + \\ drule0 evaluate_StoreEach + \\ disch_then (qspecl_then [`[3; adjust_var h'']`,`1`] mp_tac) + \\ impl_tac + >- ( + unabbrev_all_tac + \\ gvs [wordSemTheory.get_vars_def, wordSemTheory.get_var_def, + lookup_insert]) + \\ clean_tac \\ fs [] \\ UNABBREV_ALL_TAC + \\ fs [lookup_insert,FAPPLY_FUPDATE_THM,adjust_var_11,FLOOKUP_UPDATE, + code_oracle_rel_def,FLOOKUP_UPDATE] + \\ rpt (qpat_x_assum `!x y z. _` kall_tac) + \\ rw [] \\ fs [] \\ rw [] \\ fs [] + \\ fs [inter_insert_ODD_adjust_set] + >- (rw[option_le_max_right] >> metis_tac[option_le_trans]) + \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] + \\ match_mp_tac memory_rel_insert \\ fs [] + \\ fs [make_ptr_def] + \\ `TriggerGC <> EndOfHeap` by fs [] + \\ pop_assum (fn th => fs [MATCH_MP FUPDATE_COMMUTES th]) QED Theorem assign_UpdateThunk: diff --git a/compiler/backend/proofs/data_to_word_memoryProofScript.sml b/compiler/backend/proofs/data_to_word_memoryProofScript.sml index e83bae1d91..d6d526dadd 100644 --- a/compiler/backend/proofs/data_to_word_memoryProofScript.sml +++ b/compiler/backend/proofs/data_to_word_memoryProofScript.sml @@ -281,10 +281,16 @@ Termination \\ srw_tac [] [v_size_def] \\ res_tac \\ DECIDE_TAC End +Definition find_ref_def[simp]: + find_ref (ValueArray l) x = MEM x l ∧ + find_ref (Thunk m v) x = (v = x) ∧ + find_ref _ _ = F +End + (* TODO: MOVE *) Definition all_ts_def: all_ts refs stack = - let refs_v = {x | ∃n l. sptree$lookup n refs = SOME (ValueArray l) ∧ MEM x l} + let refs_v = {x | ∃n r. sptree$lookup n refs = SOME r ∧ find_ref r x} in {ts | ∃x. (x ∈ refs_v ∨ MEM x stack) ∧ MEM ts (v_all_ts x)} End @@ -628,7 +634,6 @@ Triviality RTC_lemma: gc_shared$gc_related g heap heap2 /\ f ' r IN FDOM g ==> f ' n IN FDOM g Proof - cheat (* ho_match_mp_tac RTC_INDUCT \\ full_simp_tac std_ss [] \\ rpt strip_tac \\ full_simp_tac std_ss [] \\ qpat_x_assum `bb ==> bbb` match_mp_tac \\ full_simp_tac std_ss [] @@ -636,7 +641,7 @@ Proof (rpt strip_tac \\ qpat_x_assum `!x.bb` match_mp_tac \\ metis_tac [RTC_CASES1]) \\ `RTC (ref_edge refs) r r' /\ RTC (ref_edge refs) r r` by metis_tac [RTC_CASES1] \\ res_tac \\ qpat_x_assum `!x.bb` (K ALL_TAC) - \\ full_simp_tac std_ss [bc_ref_inv_def,RefBlock_def,RTC_REFL] + \\ full_simp_tac std_ss [bc_ref_inv_def,RefBlock_def,ThunkBlock_def,RTC_REFL] \\ Cases_on `FLOOKUP f r` \\ full_simp_tac (srw_ss()) [] \\ Cases_on `FLOOKUP f r'` \\ full_simp_tac (srw_ss()) [] \\ Cases_on `lookup r refs` \\ full_simp_tac (srw_ss()) [] @@ -654,7 +659,7 @@ Proof \\ res_tac \\ CCONTR_TAC \\ full_simp_tac std_ss [] \\ srw_tac [] [] \\ POP_ASSUM MP_TAC \\ simp_tac std_ss [] \\ imp_res_tac MEM_EVERY2_IMP \\ fs [] - \\ fs [] \\ metis_tac [] *) + \\ fs [] \\ metis_tac [] QED Triviality reachable_refs_lemma: @@ -2293,11 +2298,11 @@ Theorem MEM_in_all_ts: x ∈ all_vs refs stack ∧ MEM ts (v_all_ts x) ⇒ ts ∈ all_ts refs stack Proof - cheat (* Cases \\ rw [all_vs_def,all_ts_def,v_all_ts_def] >- (drule_then ASSUME_TAC v_all_vs_MEM2 \\ fs [] \\ drule_then ASSUME_TAC v_all_vs_ts \\ fs [] - \\ metis_tac [FRANGE_FLOOKUP]) + \\ goal_assum $ drule_at Any \\ disj1_tac + \\ goal_assum drule \\ gvs []) >- (fs [MEM_FLAT,MEM_MAP] \\ rveq \\ `MEM a (v_all_vs l')` by (drule_then ASSUME_TAC v_all_vs_MEM \\ fs [MEM_v_all_vs]) @@ -2308,6 +2313,20 @@ Proof \\ `MEM ts (v_all_ts x)` by metis_tac [v_all_vs_ts_MEM] \\ qexists_tac `x` \\ rw [] \\ disj1_tac \\ asm_exists_tac \\ rw []) + >- (drule_then assume_tac v_all_vs_MEM2 \\ gvs [] + \\ drule_then assume_tac v_all_vs_ts \\ gvs [] + \\ goal_assum $ drule_at Any \\ disj1_tac + \\ goal_assum drule \\ gvs []) + >- (fs [MEM_FLAT,MEM_MAP] \\ rveq + \\ `MEM a (v_all_vs l)` + by (drule_then ASSUME_TAC v_all_vs_MEM \\ fs [MEM_v_all_vs]) + \\ drule_then ASSUME_TAC v_all_vs_MEM2 \\ fs [] + \\ drule_then ASSUME_TAC v_all_vs_ts \\ fs [] + \\ `MEM a (v_all_vs [Block n0 n l])` by rw [v_all_vs_def,MEM_v_all_vs] + \\ `MEM a (v_all_vs [x])` by metis_tac [v_all_vs_trans] + \\ `MEM ts (v_all_ts x)` by metis_tac [v_all_vs_ts_MEM] + \\ qexists_tac `x` \\ rw [] \\ disj1_tac + \\ asm_exists_tac \\ rw []) >- (drule_then ASSUME_TAC v_all_vs_MEM2 \\ fs [] \\ drule_then ASSUME_TAC v_all_vs_ts \\ metis_tac []) @@ -2316,7 +2335,7 @@ Proof \\ `MEM a (v_all_vs [Block n0 n l])` by rw [v_all_vs_def,MEM_v_all_vs] \\ `MEM a (v_all_vs [x])` by metis_tac [v_all_vs_trans] \\ `MEM ts (v_all_ts x)` by metis_tac [v_all_vs_ts_MEM] - \\ metis_tac []) *) + \\ metis_tac []) QED Theorem MEM_in_all_vs: @@ -2350,17 +2369,6 @@ Proof \\ metis_tac []) QED -(* NOT USED *) -Theorem all_ts_alt: - all_ts refs stack = { ts | ∃x. x ∈ all_vs refs stack ∧ MEM ts (v_all_ts x)} -Proof - rw [FUN_EQ_THM] - \\ EQ_TAC - \\ rw [] - >- (fs [all_ts_def,all_vs_def] \\ metis_tac [FRANGE_FLOOKUP,MEM_v_all_vs]) - >- (drule MEM_in_all_ts \\ disch_then drule \\ fs [IN_DEF]) -QED - Theorem v_inv_tf_update_thm: ∀v y f tf heap ts' a conf. v_inv conf v (y,f,tf,heap) ∧ ts' ∉ FDOM tf ⇒ @@ -3557,7 +3565,6 @@ Theorem update_byte_ref_thm: abs_ml_inv conf ((RefPtr b ptr)::stack) (insert ptr (ByteArray fl ys) refs) (roots,h1 ++ [Bytes be fl ys ws] ++ h2,be,a,sp,sp1,gens) limit ts Proof - cheat (* simp_tac std_ss [abs_ml_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def] \\ Cases_on `roots` \\ fs [v_inv_def] \\ rpt var_eq_tac \\ fs [] @@ -3614,7 +3621,7 @@ Proof \\ qpat_x_assum `_ = r'` (assume_tac o GSYM) \\ fs[isRef_def] \\ qpat_x_assum `_ = q'` (assume_tac o GSYM) \\ fs[isRef_def] \\ rveq \\ fs[isRef_def]) - >- (rveq \\ fs[isRef_def])) + >- (rveq \\ fs[isRef_def, isMutTag_def])) THEN1 (imp_res_tac unused_space_inv_byte_update \\ fs []) THEN1 (fs [INJ_DEF,DRESTRICT_DEF]) THEN1 (fs [SUBSET_DEF,DRESTRICT_DEF]) @@ -3663,7 +3670,7 @@ Proof \\ rw [] \\ ho_match_mp_tac MEM_in_all_ts \\ qexists_tac `p_2` \\ rw [] - \\ rw [all_vs_def] \\ disj1_tac + \\ rw [all_vs_def] \\ ntac 2 disj1_tac \\ map_every qexists_tac [`n`,`l`] \\ rw [lookup_insert] \\ ho_match_mp_tac MEM_v_all_vs @@ -3672,11 +3679,30 @@ Proof \\ fs [heap_lookup_def,heap_lookup_APPEND,Bytes_def, el_length_def,SUM_APPEND,RefBlock_def,heap_length_APPEND] \\ rw [] \\ fs [] \\ rfs [heap_length_def,el_length_def] \\ fs [NOT_LESS]) - \\ Cases_on `x = heap_length ha` - THEN1 (fs [INJ_DEF,FLOOKUP_DEF] \\ metis_tac []) - \\ fs [heap_lookup_APPEND,Bytes_def,heap_length_def,el_length_def,SUM_APPEND] - \\ rfs [] \\ rw [] \\ fs [] \\ rfs [heap_lookup_def] - \\ metis_tac[] *) + THEN1 + (Cases_on `x = heap_length ha` + THEN1 (fs [INJ_DEF,FLOOKUP_DEF] \\ metis_tac []) + \\ fs [heap_lookup_APPEND,Bytes_def,heap_length_def,el_length_def,SUM_APPEND] + \\ rfs [] \\ rw [] \\ fs [] \\ rfs [heap_lookup_def] + \\ metis_tac[]) + THEN1 + (once_rewrite_tac [CONJ_COMM] \\ qexists_tac `z` \\ fs [] + \\ conj_tac + THEN1 + (ho_match_mp_tac v_inv_tf_restrict + \\ conj_tac + >- metis_tac [v_inv_IMP] + \\ rw [] + \\ ho_match_mp_tac MEM_in_all_ts + \\ goal_assum $ drule_at Any \\ gvs [] + \\ rw [all_vs_def] \\ disj1_tac \\ disj2_tac + \\ qexistsl [`n`, `t'`, `a'`] + \\ rw [lookup_insert] + \\ ho_match_mp_tac MEM_v_all_vs + \\ rw [EL_MEM]) + \\ fs [heap_lookup_def,heap_lookup_APPEND,Bytes_def, + el_length_def,SUM_APPEND,ThunkBlock_def,heap_length_APPEND] + \\ rw [] \\ fs [] \\ rfs [heap_length_def,el_length_def] \\ fs [NOT_LESS]) QED val heap_store_unused_thm = prove( @@ -4139,6 +4165,7 @@ Proof \\ rw [FUN_EQ_THM,all_ts_def] \\ EQ_TAC >- (rw [] \\ fs [lookup_insert] \\ every_case_tac \\ fs [] + \\ goal_assum $ drule_at Any \\ gvs [] \\ metis_tac []) \\ rw [] >- (`ptr ≠ n` by (CCONTR_TAC \\ fs[GSYM lookup_NONE_domain]) @@ -5024,7 +5051,6 @@ Theorem all_ts_head_eq: v ∈ all_vs refs stack ⇒ all_ts refs stack = all_ts refs (v::stack) Proof - cheat (* rw [FUN_EQ_THM] \\ EQ_TAC >- (rw [all_ts_def,all_vs_def] \\ metis_tac []) @@ -5033,17 +5059,33 @@ Proof >- (Cases_on `v` \\ fs [v_all_ts_def] >- (rw [] \\ drule_then assume_tac v_all_vs_MEM2 \\ rw [] \\ qexists_tac `x` \\ rw [] - >- metis_tac [] + >- metis_tac [find_ref_def] \\ ho_match_mp_tac v_all_vs_ts_MEM \\ qexists_tac `Block n0 n' l'` \\ rw [v_all_ts_def]) \\ drule_then assume_tac v_all_vs_MEM2 \\ rw [] \\ qexists_tac `x'` \\ rw [v_all_ts_def] - >- metis_tac [] + >- metis_tac [find_ref_def] \\ rw [] \\ ho_match_mp_tac v_all_vs_ts_MEM \\ qexists_tac `Block n0 n' l'` \\ rw [v_all_ts_def]) >- metis_tac [] >- metis_tac [] + >- (Cases_on `v` \\ fs [v_all_ts_def] + >- (rw [] + \\ drule_then assume_tac v_all_vs_MEM2 + \\ rw [] + \\ qexists_tac `x'` \\ rw [] + >- metis_tac [find_ref_def] + \\ ho_match_mp_tac v_all_vs_ts + \\ metis_tac []) + \\ drule_then assume_tac v_all_vs_MEM2 \\ rw [] + \\ qexists_tac `x'`\\ rw [v_all_ts_def] + >- metis_tac [find_ref_def] + \\ ho_match_mp_tac v_all_vs_ts_MEM + \\ qexists_tac `Block n0 n' l` + \\ rw [v_all_ts_def]) + >- metis_tac [] + >- metis_tac [] >- (Cases_on `v` \\ fs [v_all_ts_def] >- (rw [] \\ drule_then assume_tac v_all_vs_MEM2 @@ -5056,7 +5098,7 @@ Proof \\ ho_match_mp_tac v_all_vs_ts_MEM \\ qexists_tac `Block n0 n l` \\ rw [v_all_ts_def]) - >- metis_tac [] *) + >- metis_tac [] QED Theorem memory_rel_El': @@ -5312,7 +5354,6 @@ val gc_kind_update_Ref = prove( (ha ++ DataElement (ys1 ++ y::ys2) l (RefTag,[])::hb) ==> gc_kind_inv c a sp sp1 gens (ha ++ DataElement (ys1 ++ z::ys2) l (RefTag,[])::hb)``, - cheat (* fs [gc_kind_inv_def] \\ every_case_tac \\ fs [] \\ ntac 2 strip_tac THEN1 (Cases_on `gens` \\ fs [gen_state_ok_def,EVERY_MEM] @@ -5329,12 +5370,12 @@ val gc_kind_update_Ref = prove( \\ fs [MEM_APPEND,METIS_PROVE [] ``(!x. p x \/ q x ==> d x) <=> (!x. p x ==> d x) /\ (!x. q x ==> d x)``] - \\ fs [isRef_def]) + \\ fs [isRef_def, isMutTag_def]) \\ fs [heap_split_SOME_APPEND] \\ CASE_TAC \\ rw [] \\ fs [isRef_def] \\ fs [heap_split_def,el_length_def] \\ rfs [] \\ rpt (CASE_TAC \\ fs []) - \\ rveq \\ fs [isRef_def] *)); + \\ rveq \\ fs [isRef_def]); Theorem v_all_vs_append: ∀x y. v_all_vs (x ++ y) = v_all_vs x ++ v_all_vs y @@ -6048,6 +6089,27 @@ Proof \\ fs [AC STAR_ASSOC STAR_COMM] \\ fs [STAR_ASSOC] QED +Theorem memory_rel_AllocThunk: + memory_rel c be ts refs sp st m dm ((v,w)::vars) /\ + encode_header c (case ev of + | Evaluated => 14 + | NotEvaluated => 6) 1 = SOME hd /\ + ~(new IN (domain refs)) /\ + 2 ≤ sp /\ good_dimindex (:'a) ==> + ?eoh (curr:'a word) trig m1. + FLOOKUP st EndOfHeap = SOME (Word eoh) /\ + FLOOKUP st TriggerGC = SOME (Word trig) /\ + FLOOKUP st CurrHeap = SOME (Word curr) /\ + let w' = eoh - bytes_in_word * 2w in + let w1 = trig - bytes_in_word * 2w in + store_list w' [Word hd; w] m dm = SOME m1 /\ + memory_rel c be ts (insert new (Thunk ev v) refs) (sp - 2) + (st |+ (EndOfHeap,Word w') |+ (TriggerGC,Word w1)) m1 dm + ((RefPtr F new,make_ptr c (w' - curr) 0w 1)::vars) +Proof + cheat +QED + Theorem memory_rel_write: memory_rel c be ts refs sp st m dm vars ==> ?(free:'a word). @@ -14044,13 +14106,19 @@ Proof \\ ‘all_ts (insert p2 (ByteArray fl2 res_vals) refs) = all_ts refs’ by (gvs [all_ts_def,FUN_EQ_THM,lookup_insert,CaseEq"bool"] - \\ ‘∀n l. lookup n refs = SOME (ValueArray l) ⇔ - lookup n refs = SOME (ValueArray l) ∧ n ≠ p2’ by - (rw [] \\ eq_tac \\ rw [] \\ gvs [] - \\ CCONTR_TAC \\ gvs []) - \\ rpt gen_tac - \\ pop_assum (fn th => CONV_TAC (RAND_CONV $ ONCE_REWRITE_CONV [th])) - \\ simp [AC CONJ_ASSOC CONJ_COMM]) + \\ rpt gen_tac + \\ eq_tac \\ gvs [] + >- (rw [] \\ gvs [find_ref_def] \\ metis_tac []) + \\ rw [] \\ gvs [] + >- ( + goal_assum $ drule_at Any \\ gvs [] + \\ Cases_on `r` \\ gvs [] + \\ ( + disj1_tac \\ gvs [] + \\ qmatch_asmsub_abbrev_tac `lookup n refs = SOME rv` + \\ qexistsl [`n`, `rv`] \\ gvs [Abbr`rv`] + \\ CCONTR_TAC \\ gvs [])) + \\ metis_tac []) \\ ‘∀v x. v_inv c v (x,f,tf,heap1) = v_inv c v (x,f,tf,heap0)’ by (ho_match_mp_tac v_inv_alt_ind \\ simp [v_inv_def,Bignum_def,i2mw_def,Word64Rep_def] From f1ad1f96a75bc86ec5772dd6e4a6b767d02a2b57 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 31 Jul 2025 11:24:33 +0300 Subject: [PATCH 032/112] Prove more cheats in `data_to_word_memoryProof` --- .../proofs/data_to_word_memoryProofScript.sml | 197 +++++++++++++----- 1 file changed, 145 insertions(+), 52 deletions(-) diff --git a/compiler/backend/proofs/data_to_word_memoryProofScript.sml b/compiler/backend/proofs/data_to_word_memoryProofScript.sml index d6d526dadd..9ecb35a931 100644 --- a/compiler/backend/proofs/data_to_word_memoryProofScript.sml +++ b/compiler/backend/proofs/data_to_word_memoryProofScript.sml @@ -3188,7 +3188,6 @@ Theorem update_ref_thm: abs_ml_inv conf (xs ++ (RefPtr b ptr)::stack) (insert ptr (ValueArray xs) refs) (roots,heap2,be,a,sp,sp1,gens) limit ts Proof - cheat (* simp_tac std_ss [abs_ml_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def] \\ imp_res_tac EVERY2_APPEND_CONS @@ -3232,7 +3231,7 @@ Proof \\ fs[] \\ fs[heap_lookup_APPEND] \\ every_case_tac \\ fs[] \\ rfs[] \\ qpat_x_assum `heap_lookup _ _ = SOME (RefBlock zs)` assume_tac \\ drule heap_lookup_SPLIT \\ strip_tac \\ fs[] \\ rveq \\ fs[] - THEN1 fs[RefBlock_def,isRef_def] + THEN1 fs[RefBlock_def,isRef_def,isMutTag_def] \\ qpat_x_assum `heap_store _ _ _ = _` mp_tac \\ SIMP_TAC std_ss [GSYM APPEND_ASSOC,APPEND,heap_store_lemma] \\ disch_then (assume_tac o GSYM) \\ fs[] @@ -3299,13 +3298,28 @@ Proof \\ rw [] \\ ho_match_mp_tac MEM_in_all_ts \\ qexists_tac `p_2` \\ rw [] - \\ rw [all_vs_def] \\ disj1_tac + \\ rw [all_vs_def] \\ ntac 2 disj1_tac \\ map_every qexists_tac [`n`,`l`] \\ rw [lookup_insert] \\ ho_match_mp_tac MEM_v_all_vs \\ drule MEM_ZIP2 \\ rw [] \\ rw [EL_MEM])) - \\ (full_simp_tac (srw_ss()) [INJ_DEF] \\ metis_tac []) *) + >- (full_simp_tac (srw_ss()) [INJ_DEF] \\ metis_tac []) + >- ( + qexists `z` \\ conj_tac + >- ( + first_x_assum ho_match_mp_tac \\ rw [] + \\ CCONTR_TAC + \\ metis_tac [INJ_DEF]) + \\ ho_match_mp_tac v_inv_tf_restrict + \\ rw [] + \\ ho_match_mp_tac MEM_in_all_ts + \\ goal_assum $ drule_at Any \\ gvs [] + \\ rw [all_vs_def] \\ disj1_tac \\ disj2_tac + \\ qexistsl [`n`, `t`, `a'`] \\ gvs [] + \\ simp [lookup_insert] + \\ ho_match_mp_tac MEM_v_all_vs + \\ simp [EL_MEM]) QED Definition heap_deref_def: @@ -3328,7 +3342,6 @@ Theorem update_ref_thm1: (insert ptr (ValueArray (LUPDATE (HD xs) i xs1)) refs) (roots,heap2,be,a,sp,sp1,gens) limit ts Proof - cheat (* simp_tac std_ss [abs_ml_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def] \\ imp_res_tac EVERY2_APPEND_CONS @@ -3376,7 +3389,7 @@ Proof \\ fs[] \\ fs[heap_lookup_APPEND] \\ every_case_tac \\ fs[] \\ rfs[] \\ qpat_x_assum `heap_lookup _ _ = SOME (RefBlock zs)` assume_tac \\ drule heap_lookup_SPLIT \\ strip_tac \\ fs[] \\ rveq \\ fs[] - THEN1 fs[RefBlock_def,isRef_def] + THEN1 fs[RefBlock_def,isRef_def,isMutTag_def] \\ qpat_x_assum `heap_store _ _ _ = _` mp_tac \\ SIMP_TAC std_ss [GSYM APPEND_ASSOC,APPEND,heap_store_lemma] \\ disch_then (assume_tac o GSYM) \\ fs[] @@ -3429,7 +3442,7 @@ Proof \\ rw [] \\ ho_match_mp_tac MEM_in_all_ts \\ qexists_tac `p_2` \\ rw [] - \\ rw [all_vs_def] \\ disj1_tac + \\ rw [all_vs_def] \\ ntac 2 disj1_tac \\ map_every qexists_tac [`n`,`LUPDATE (HD xs) i xs1`] \\ rw [FLOOKUP_UPDATE,FLOOKUP_DEF] \\ ho_match_mp_tac MEM_v_all_vs @@ -3457,13 +3470,28 @@ Proof \\ rw [] \\ ho_match_mp_tac MEM_in_all_ts \\ qexists_tac `p_2` \\ rw [] - \\ rw [all_vs_def] \\ disj1_tac + \\ rw [all_vs_def] \\ ntac 2 disj1_tac \\ map_every qexists_tac [`n`,`l`] \\ rw [lookup_insert] \\ ho_match_mp_tac MEM_v_all_vs \\ drule MEM_ZIP2 \\ rw [] \\ rw [EL_MEM])) - \\ full_simp_tac (srw_ss()) [INJ_DEF] \\ metis_tac [] *) + >- (full_simp_tac (srw_ss()) [INJ_DEF] \\ metis_tac []) + >- ( + qexists `z` \\ conj_tac + >- ( + first_x_assum ho_match_mp_tac \\ rw [] + \\ CCONTR_TAC + \\ metis_tac [INJ_DEF]) + \\ ho_match_mp_tac v_inv_tf_restrict + \\ rw [] + \\ ho_match_mp_tac MEM_in_all_ts + \\ goal_assum $ drule_at Any \\ gvs [] + \\ rw [all_vs_def] \\ disj1_tac \\ disj2_tac + \\ qexistsl [`n`, `t`, `a'`] \\ gvs [] + \\ simp [lookup_insert] + \\ ho_match_mp_tac MEM_v_all_vs + \\ simp [EL_MEM]) QED (* update byte ref *) @@ -3779,7 +3807,6 @@ Theorem new_ref_thm: (rs ++ Pointer (a+sp+sp1-(LENGTH xs + 1)) (Word 0w)::roots2,heap2,be,a, sp - (LENGTH xs + 1),sp1,gens) limit ts Proof - cheat (* simp_tac std_ss [abs_ml_inv_def] \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def] \\ imp_res_tac EVERY2_APPEND_IMP_APPEND @@ -3914,6 +3941,30 @@ Proof \\ Cases_on `lookup n refs` \\ full_simp_tac (srw_ss()) [] \\ full_simp_tac (srw_ss()) [FDOM_FUPDATE,FAPPLY_FUPDATE_THM,FLOOKUP_DEF,lookup_insert] \\ reverse (Cases_on `x'`) \\ full_simp_tac (srw_ss()) [] + >- ( + `isSomeDataElement (heap_lookup (f ' n) heap)` by + (full_simp_tac std_ss [RefBlock_def] \\ EVAL_TAC + \\ simp_tac (srw_ss()) [] \\ NO_TAC) + \\ res_tac \\ full_simp_tac std_ss [] \\ simp_tac (srw_ss()) [RefBlock_def] + \\ qpat_x_assum `n IN FDOM f` ASSUME_TAC + \\ `n IN (domain refs)` by fs [domain_lookup] + \\ qpat_x_assum `lookup n refs = SOME (Thunk t a')` ASSUME_TAC + \\ full_simp_tac (srw_ss()) [] + \\ srw_tac [] [] \\ full_simp_tac std_ss [RefBlock_def,ThunkBlock_def] + \\ imp_res_tac heap_store_rel_lemma + \\ res_tac \\ full_simp_tac (srw_ss()) [] + \\ ho_match_mp_tac v_inv_tf_restrict + \\ conj_tac + >- (match_mp_tac v_inv_SUBMAP + \\ full_simp_tac (srw_ss()) []) + \\ rw [] + \\ ho_match_mp_tac MEM_in_all_ts + \\ qexists_tac `a'` \\ rw [] + \\ rw [all_vs_def] \\ disj1_tac \\ disj2_tac + \\ qexistsl [`n`,`t`, `a'`] + \\ fs [lookup_insert] + \\ ho_match_mp_tac MEM_v_all_vs + \\ rw []) THEN1 (imp_res_tac heap_store_rel_lemma \\ fs [Bytes_def] \\ metis_tac[]) \\ `isSomeDataElement (heap_lookup (f ' n) heap)` by (full_simp_tac std_ss [RefBlock_def] \\ EVAL_TAC @@ -3937,11 +3988,11 @@ Proof \\ rw [] \\ ho_match_mp_tac MEM_in_all_ts \\ qexists_tac `y` \\ rw [] - \\ rw [all_vs_def] \\ disj1_tac + \\ rw [all_vs_def] \\ ntac 2 disj1_tac \\ map_every qexists_tac [`n`,`l`] \\ fs [lookup_insert] \\ ho_match_mp_tac MEM_v_all_vs - \\ rw [] *) + \\ rw [] QED (* deref *) @@ -3966,8 +4017,11 @@ Theorem deref_thm: ?y. (heap_el r n heap = (y,T)) /\ abs_ml_inv conf (EL n vs::RefPtr b ptr::stack) refs (y::roots,heap,be,a,sp,sp1,gens) limit ts + | Thunk m v => + ?y. (heap_el r 0 heap = (y,T)) /\ + abs_ml_inv conf (v::RefPtr b ptr::stack) refs + (y::roots,heap,be,a,sp,sp1,gens) limit ts Proof - cheat (* full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def] \\ rpt strip_tac \\ Cases_on `roots` \\ full_simp_tac (srw_ss()) [LIST_REL_def] \\ full_simp_tac std_ss [v_inv_def] @@ -3980,46 +4034,85 @@ Proof \\ `ptr IN (domain refs)` by fs [SUBSET_DEF] \\ full_simp_tac (srw_ss()) [domain_lookup] \\ reverse (Cases_on `v`) \\ full_simp_tac (srw_ss()) [] - \\ NTAC 3 strip_tac - \\ imp_res_tac EVERY2_IMP_LENGTH - \\ asm_simp_tac (srw_ss()) [heap_el_def,RefBlock_def] - \\ srw_tac [] [] THEN1 - (full_simp_tac std_ss [roots_ok_def,heap_ok_def] - \\ imp_res_tac heap_lookup_MEM - \\ strip_tac \\ once_rewrite_tac [MEM] \\ once_rewrite_tac [EQ_SYM_EQ] - \\ rpt strip_tac \\ res_tac - \\ full_simp_tac std_ss [RefBlock_def] - \\ res_tac \\ full_simp_tac std_ss [MEM] + >- ( + strip_tac + \\ imp_res_tac EVERY2_IMP_LENGTH + \\ asm_simp_tac (srw_ss()) [heap_el_def,RefBlock_def,ThunkBlock_def] + \\ srw_tac [] [] THEN1 + (full_simp_tac std_ss [roots_ok_def,heap_ok_def] + \\ imp_res_tac heap_lookup_MEM + \\ strip_tac \\ once_rewrite_tac [MEM] \\ once_rewrite_tac [EQ_SYM_EQ] + \\ rpt strip_tac \\ res_tac + \\ full_simp_tac std_ss [RefBlock_def,ThunkBlock_def] + \\ res_tac \\ full_simp_tac std_ss [MEM] + \\ FIRST_X_ASSUM match_mp_tac + \\ metis_tac [MEM_EL]) + \\ qexists_tac `f` \\ full_simp_tac std_ss [] + \\ qexists_tac `tf` \\ full_simp_tac std_ss [] + \\ conj_tac + >- (`all_ts refs (RefPtr b ptr::stack) = all_ts refs (a'::RefPtr b ptr::stack)` + suffices_by metis_tac [] + \\ rw [FUN_EQ_THM,all_ts_def] + \\ EQ_TAC + >- metis_tac [] + \\ rw [] + >- metis_tac [] + >- (qexists_tac `a'` \\ rw [] \\ disj1_tac + \\ metis_tac [EL_MEM,FRANGE_FLOOKUP,FLOOKUP_DEF,find_ref_def]) + \\ metis_tac []) + \\ imp_res_tac EVERY2_IMP_EL + \\ full_simp_tac std_ss [] + \\ rpt strip_tac \\ FIRST_X_ASSUM match_mp_tac - \\ metis_tac [MEM_EL]) - \\ qexists_tac `f` \\ full_simp_tac std_ss [] - \\ qexists_tac `tf` \\ full_simp_tac std_ss [] - \\ conj_tac - >- (`all_ts refs (RefPtr b ptr::stack) = all_ts refs (EL n l::RefPtr b ptr::stack)` - suffices_by metis_tac [] - \\ rw [FUN_EQ_THM,all_ts_def] - \\ EQ_TAC - >- metis_tac [] - \\ rw [] - >- metis_tac [] - >- (qexists_tac `EL n l` \\ rw [] \\ disj1_tac - \\ metis_tac [EL_MEM,FRANGE_FLOOKUP,FLOOKUP_DEF]) - \\ metis_tac []) - \\ imp_res_tac EVERY2_IMP_EL - \\ full_simp_tac std_ss [] - \\ rpt strip_tac - \\ FIRST_X_ASSUM match_mp_tac - \\ qpat_x_assum `reachable_refs (RefPtr b ptr::stack) refs ptr` (K ALL_TAC) - \\ full_simp_tac std_ss [reachable_refs_def] - \\ reverse (Cases_on `x = EL n l`) - THEN1 (full_simp_tac std_ss [MEM] \\ metis_tac []) - \\ qexists_tac `RefPtr b ptr` \\ simp_tac std_ss [MEM,get_refs_def] - \\ once_rewrite_tac [RTC_CASES1] \\ DISJ2_TAC - \\ qexists_tac `r` \\ full_simp_tac std_ss [] - \\ full_simp_tac (srw_ss()) [ref_edge_def,FLOOKUP_DEF,get_refs_def] - \\ full_simp_tac (srw_ss()) [MEM_FLAT,MEM_MAP,PULL_EXISTS] - \\ qexists_tac `(EL n l)` \\ full_simp_tac std_ss [] - \\ full_simp_tac std_ss [MEM_EL] \\ metis_tac [] *) + \\ qpat_x_assum `reachable_refs (RefPtr b ptr::stack) refs ptr` (K ALL_TAC) + \\ full_simp_tac std_ss [reachable_refs_def] + \\ reverse (Cases_on `x = a'`) + THEN1 (full_simp_tac std_ss [MEM] \\ metis_tac []) + \\ qexists_tac `RefPtr b ptr` \\ simp_tac std_ss [MEM,get_refs_def] + \\ once_rewrite_tac [RTC_CASES1] \\ DISJ2_TAC + \\ qexists_tac `r` \\ full_simp_tac std_ss [] + \\ full_simp_tac (srw_ss()) [ref_edge_def,FLOOKUP_DEF,get_refs_def]) + >- ( + NTAC 3 strip_tac + \\ imp_res_tac EVERY2_IMP_LENGTH + \\ asm_simp_tac (srw_ss()) [heap_el_def,RefBlock_def] + \\ srw_tac [] [] THEN1 + (full_simp_tac std_ss [roots_ok_def,heap_ok_def] + \\ imp_res_tac heap_lookup_MEM + \\ strip_tac \\ once_rewrite_tac [MEM] \\ once_rewrite_tac [EQ_SYM_EQ] + \\ rpt strip_tac \\ res_tac + \\ full_simp_tac std_ss [RefBlock_def] + \\ res_tac \\ full_simp_tac std_ss [MEM] + \\ FIRST_X_ASSUM match_mp_tac + \\ metis_tac [MEM_EL]) + \\ qexists_tac `f` \\ full_simp_tac std_ss [] + \\ qexists_tac `tf` \\ full_simp_tac std_ss [] + \\ conj_tac + >- (`all_ts refs (RefPtr b ptr::stack) = all_ts refs (EL n l::RefPtr b ptr::stack)` + suffices_by metis_tac [] + \\ rw [FUN_EQ_THM,all_ts_def] + \\ EQ_TAC + >- metis_tac [] + \\ rw [] + >- metis_tac [] + >- (qexists_tac `EL n l` \\ rw [] \\ disj1_tac + \\ metis_tac [EL_MEM,FRANGE_FLOOKUP,FLOOKUP_DEF,find_ref_def]) + \\ metis_tac []) + \\ imp_res_tac EVERY2_IMP_EL + \\ full_simp_tac std_ss [] + \\ rpt strip_tac + \\ FIRST_X_ASSUM match_mp_tac + \\ qpat_x_assum `reachable_refs (RefPtr b ptr::stack) refs ptr` (K ALL_TAC) + \\ full_simp_tac std_ss [reachable_refs_def] + \\ reverse (Cases_on `x = EL n l`) + THEN1 (full_simp_tac std_ss [MEM] \\ metis_tac []) + \\ qexists_tac `RefPtr b ptr` \\ simp_tac std_ss [MEM,get_refs_def] + \\ once_rewrite_tac [RTC_CASES1] \\ DISJ2_TAC + \\ qexists_tac `r` \\ full_simp_tac std_ss [] + \\ full_simp_tac (srw_ss()) [ref_edge_def,FLOOKUP_DEF,get_refs_def] + \\ full_simp_tac (srw_ss()) [MEM_FLAT,MEM_MAP,PULL_EXISTS] + \\ qexists_tac `(EL n l)` \\ full_simp_tac std_ss [] + \\ full_simp_tac std_ss [MEM_EL] \\ metis_tac []) QED (* el *) From ca339d79c67ef844eae1e18d639f7662ea474a64 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 31 Jul 2025 13:23:10 +0300 Subject: [PATCH 033/112] Progress in `data_to_word_memoryProof` --- .../proofs/data_to_word_memoryProofScript.sml | 291 +++++++++++++++++- 1 file changed, 290 insertions(+), 1 deletion(-) diff --git a/compiler/backend/proofs/data_to_word_memoryProofScript.sml b/compiler/backend/proofs/data_to_word_memoryProofScript.sml index 9ecb35a931..b7b430f290 100644 --- a/compiler/backend/proofs/data_to_word_memoryProofScript.sml +++ b/compiler/backend/proofs/data_to_word_memoryProofScript.sml @@ -2889,6 +2889,16 @@ Proof \\ rw [lookup_insert] QED +Triviality ref_edge_Thunk: + ref_edge (insert ptr (Thunk ev v) refs) x y = + if x = ptr then MEM y (get_refs (Block 0 ARB [v])) else ref_edge refs x y +Proof + simp_tac std_ss [FUN_EQ_THM,ref_edge_def] \\ rpt strip_tac + \\ full_simp_tac (srw_ss()) [FLOOKUP_DEF,FAPPLY_FUPDATE_THM] + \\ Cases_on `x = ptr` \\ full_simp_tac (srw_ss()) [] + \\ rw [lookup_insert] +QED + Triviality reachable_refs_UPDATE: reachable_refs (xs ++ RefPtr b ptr::stack) (insert ptr (ValueArray xs) refs) n ==> reachable_refs (xs ++ RefPtr b ptr::stack) refs n @@ -2913,6 +2923,30 @@ Proof \\ full_simp_tac std_ss [] \\ res_tac QED +Triviality reachable_refs_Thunk_UPDATE: + reachable_refs (v::RefPtr F ptr::stack) (insert ptr (Thunk ev v) refs) n ==> + reachable_refs (v::RefPtr F ptr::stack) refs n +Proof + full_simp_tac std_ss [reachable_refs_def] \\ rpt strip_tac + \\ Cases_on `?m. MEM m (get_refs (Block 0 ARB [v])) /\ + RTC (ref_edge refs) m n` THEN1 + (full_simp_tac std_ss [get_refs_def,MEM_FLAT,MEM_MAP] + \\ gvs [] \\ metis_tac []) + \\ full_simp_tac std_ss [METIS_PROVE [] ``~b \/ c <=> b ==> c``] + \\ full_simp_tac std_ss [] \\ Q.LIST_EXISTS_TAC [`x`,`r`] + \\ full_simp_tac std_ss [] + \\ full_simp_tac std_ss [RTC_eq_NRC] + \\ Q.ABBREV_TAC `k = n'` \\ POP_ASSUM (K ALL_TAC) \\ qexists_tac `k` + \\ POP_ASSUM MP_TAC \\ POP_ASSUM MP_TAC \\ REPEAT (POP_ASSUM (K ALL_TAC)) + \\ Q.SPEC_TAC (`r`,`r`) \\ Induct_on `k` + \\ full_simp_tac std_ss [NRC] + \\ rpt strip_tac \\ full_simp_tac std_ss [] \\ res_tac + \\ qexists_tac `z` \\ full_simp_tac std_ss [] + \\ full_simp_tac std_ss [ref_edge_Thunk] + \\ reverse (Cases_on `r = ptr`) + \\ full_simp_tac std_ss [] \\ res_tac +QED + Triviality reachable_refs_UPDATE1: reachable_refs (xs ++ RefPtr b ptr::stack) (insert ptr (ValueArray xs1) refs) n ==> (!v. MEM v xs1 ==> ~MEM v xs ==> ?xs2. (lookup ptr refs = SOME (ValueArray xs2)) /\ MEM v xs2) ==> @@ -3995,6 +4029,207 @@ Proof \\ rw [] QED +Theorem new_thunk_thm: + abs_ml_inv conf (v::stack) refs (roots,heap,be,a,sp,sp1,gens) limit ts ∧ + ¬(ptr IN (domain refs)) ∧ 2 ≤ sp ⇒ + ∃p r roots2 heap2. + (roots = r::roots2) ∧ + (heap_store_unused a (sp+sp1) (ThunkBlock ev r) heap = (heap2,T)) /\ + abs_ml_inv conf (v::(RefPtr F ptr)::stack) (insert ptr (Thunk ev v) refs) + (r::Pointer (a+sp+sp1-2) (Word 0w)::roots2,heap2,be,a, + sp - 2,sp1,gens) limit ts +Proof + simp_tac std_ss [abs_ml_inv_def] + \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def] + \\ imp_res_tac EVERY2_APPEND_IMP_APPEND + \\ full_simp_tac (srw_ss()) [] + \\ imp_res_tac EVERY2_IMP_LENGTH + \\ `el_length (ThunkBlock ev x) <= sp + sp1` by ( + full_simp_tac std_ss + [el_length_def,ThunkBlock_def] \\ fs []) + \\ qpat_x_assum `unused_space_inv a (sp+sp1) heap` (fn th => + MATCH_MP (IMP_heap_store_unused + |> REWRITE_RULE [GSYM AND_IMP_INTRO] |> GEN_ALL) th + |> ASSUME_TAC) + \\ POP_ASSUM (MP_TAC o Q.SPEC `ThunkBlock ev x`) \\ match_mp_tac IMP_IMP + \\ strip_tac THEN1 full_simp_tac std_ss [ThunkBlock_def,el_length_def] + \\ strip_tac \\ full_simp_tac std_ss [] + \\ `unused_space_inv a (sp + sp1 - 2) heap2` + by fs [ThunkBlock_def,el_length_def] + \\ full_simp_tac std_ss [] \\ strip_tac THEN1 + (full_simp_tac std_ss [roots_ok_def,MEM,heap_store_rel_def] \\ rpt strip_tac + \\ full_simp_tac (srw_ss()) [ThunkBlock_def,el_length_def] + \\ full_simp_tac (srw_ss()) [isSomeDataElement_def] + \\ fs [] \\ metis_tac []) + \\ strip_tac THEN1 + (full_simp_tac std_ss [heap_ok_def,ThunkBlock_def,isForwardPointer_def] + \\ once_rewrite_tac [EQ_SYM_EQ] \\ rpt strip_tac THEN1 + (POP_ASSUM MP_TAC \\ full_simp_tac (srw_ss()) [] + \\ once_rewrite_tac [EQ_SYM_EQ] \\ rpt strip_tac + \\ full_simp_tac (srw_ss()) [roots_ok_def,MEM] + \\ metis_tac [heap_store_rel_def]) + \\ res_tac \\ full_simp_tac std_ss [heap_store_rel_def]) + \\ conj_tac THEN1 + (fs [gc_kind_inv_def] \\ Cases_on `conf.gc_kind` \\ fs [] + \\ conj_tac THEN1 + (drule heap_store_unused_gen_state_ok + \\ fs [EVAL ``el_length (ThunkBlock ev x)``]) + \\ drule (GEN_ALL heap_store_unused_thm) + \\ disch_then drule \\ fs [] + \\ strip_tac \\ fs [] \\ rveq \\ fs [] + \\ fs [EVAL ``el_length (ThunkBlock ev x)``] + \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] + \\ once_rewrite_tac [heap_split_APPEND_if] \\ fs [] + \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] + \\ once_rewrite_tac [heap_split_APPEND_if] + \\ fs [heap_length_heap_expand,ThunkBlock_def] + \\ fs [heap_split_def] + \\ gvs [isRef_def,isMutTag_def] + \\ EVAL_TAC \\ rw [] \\ EVAL_TAC) + \\ `~(ptr IN FDOM f)` by (full_simp_tac (srw_ss()) [SUBSET_DEF] \\ metis_tac []) + \\ conj_tac THEN1 fs [] + \\ qexists_tac `f |+ (ptr,a+sp+sp1-2)` + \\ qexists_tac `DRESTRICT tf (all_ts (insert ptr (Thunk ev v) refs) (v::RefPtr F ptr::stack))` + \\ strip_tac THEN1 + (full_simp_tac (srw_ss()) [FDOM_FUPDATE] + \\ `(FAPPLY (f |+ (ptr,a + sp + sp1 - 2))) = + (ptr =+ (a+sp+sp1-2)) (FAPPLY f)` by + (full_simp_tac std_ss [FUN_EQ_THM,FAPPLY_FUPDATE_THM,APPLY_UPDATE_THM] + \\ metis_tac []) \\ full_simp_tac std_ss [] + \\ match_mp_tac (METIS_PROVE [] ``!y. (x = y) /\ f y ==> f x``) + \\ qexists_tac `(a + sp + sp1 - 2) INSERT + {a | isSomeDataElement (heap_lookup a heap)}` + \\ strip_tac + THEN1 (fs [ThunkBlock_def,isDataElement_def,el_length_def]) + \\ match_mp_tac INJ_UPDATE \\ full_simp_tac std_ss [] + \\ full_simp_tac (srw_ss()) [] + \\ full_simp_tac std_ss [ThunkBlock_def,el_length_def] \\ fs []) + \\ strip_tac THEN1 + (full_simp_tac (srw_ss()) [SUBSET_DEF,FDOM_FUPDATE] \\ metis_tac []) + \\ strip_tac + THEN1 (fs [INJ_DEF,DRESTRICT_DEF,heap_store_rel_def]) + \\ strip_tac + THEN1 (fs [DRESTRICT_DEF,SUBSET_DEF]) + \\ strip_tac + THEN1 (fs [DRESTRICT_DEF,SUBSET_DEF,IN_INTER]) + \\ Q.ABBREV_TAC `f1 = f |+ (ptr,a + sp + sp1 - 2)` + \\ `f SUBMAP f1` by + (Q.UNABBREV_TAC `f1` \\ full_simp_tac (srw_ss()) [SUBMAP_DEF,FAPPLY_FUPDATE_THM] + \\ metis_tac []) + \\ strip_tac THEN1 + (full_simp_tac std_ss [LIST_REL_def] + \\ match_mp_tac (METIS_PROVE [] ``p2 /\ (p1 /\ p3) ==> p1 /\ p2 /\ p3``) + \\ strip_tac THEN1 (UNABBREV_ALL_TAC \\ fs [v_inv_def]) + \\ full_simp_tac (srw_ss()) [v_inv_def,FAPPLY_FUPDATE_THM] + \\ full_simp_tac std_ss [EVERY2_EQ_EL] + \\ imp_res_tac EVERY2_IMP_LENGTH + \\ conj_tac + >- (rw [] + \\ ho_match_mp_tac v_inv_tf_restrict + \\ rw [] + >- (ho_match_mp_tac v_inv_SUBMAP \\ rw []) + \\ ho_match_mp_tac MEM_in_all_ts + \\ qexists_tac `v` \\ rw [] + \\ rw [all_vs_def] \\ disj2_tac + \\ ho_match_mp_tac MEM_v_all_vs + \\ rw [MEM_APPEND,EL_MEM]) + >- (rw [] + \\ ho_match_mp_tac v_inv_tf_restrict + \\ rw [] + >- (ho_match_mp_tac v_inv_SUBMAP \\ rw []) + \\ ho_match_mp_tac MEM_in_all_ts + \\ qexists_tac `EL n stack` \\ rw [] + \\ rw [all_vs_def] \\ disj2_tac + \\ ho_match_mp_tac MEM_v_all_vs + \\ rw [MEM_APPEND,EL_MEM])) + \\ rpt strip_tac + \\ Cases_on `n = ptr` THEN1 + (Q.UNABBREV_TAC `f1` \\ asm_simp_tac (srw_ss()) [bc_ref_inv_def,FDOM_FUPDATE, + FAPPLY_FUPDATE_THM] \\ fs [el_length_def,RefBlock_def,ThunkBlock_def] + \\ full_simp_tac (srw_ss()) [FLOOKUP_DEF,EVERY2_EQ_EL] + \\ rpt strip_tac + \\ ho_match_mp_tac v_inv_tf_restrict + \\ conj_tac + >- (match_mp_tac v_inv_SUBMAP \\ full_simp_tac (srw_ss()) []) + \\ rw [] + \\ ho_match_mp_tac MEM_in_all_ts + \\ qexists_tac `v` \\ rw [] + \\ rw [all_vs_def] \\ disj2_tac + \\ ho_match_mp_tac MEM_v_all_vs + \\ rw [MEM_APPEND,EL_MEM]) + \\ `reachable_refs (v::RefPtr F ptr::stack) refs n` + by imp_res_tac reachable_refs_Thunk_UPDATE + \\ qpat_x_assum `reachable_refs (v::RefPtr F ptr::stack) + (insert ptr _ refs) n` (K ALL_TAC) + \\ `reachable_refs (v::stack) refs n` by + (full_simp_tac std_ss [reachable_refs_def] + \\ reverse (Cases_on `x' = RefPtr F ptr`) + THEN1 (full_simp_tac std_ss [MEM,MEM_APPEND] \\ metis_tac []) + \\ full_simp_tac std_ss [get_refs_def,MEM] + \\ srw_tac [] [] + \\ imp_res_tac RTC_NRC + \\ Cases_on `n'` \\ full_simp_tac std_ss [NRC] + \\ full_simp_tac std_ss [ref_edge_def,lookup_def] + \\ every_case_tac \\ rev_full_simp_tac std_ss [GSYM lookup_NONE_domain]) + \\ res_tac \\ Q.UNABBREV_TAC `f1` \\ full_simp_tac std_ss [bc_ref_inv_def] + \\ Cases_on `FLOOKUP f n` \\ full_simp_tac (srw_ss()) [] + \\ Cases_on `lookup n refs` \\ full_simp_tac (srw_ss()) [] + \\ full_simp_tac (srw_ss()) [FDOM_FUPDATE,FAPPLY_FUPDATE_THM,FLOOKUP_DEF,lookup_insert] + \\ reverse (Cases_on `x''`) \\ full_simp_tac (srw_ss()) [] + >- ( + `isSomeDataElement (heap_lookup (f ' n) heap)` by + (full_simp_tac std_ss [ThunkBlock_def] \\ EVAL_TAC + \\ simp_tac (srw_ss()) [] \\ NO_TAC) + \\ res_tac \\ full_simp_tac std_ss [] \\ simp_tac (srw_ss()) [RefBlock_def] + \\ qpat_x_assum `n IN FDOM f` ASSUME_TAC + \\ `n IN (domain refs)` by fs [domain_lookup] + \\ qpat_x_assum `lookup n refs = SOME (Thunk t a')` ASSUME_TAC + \\ full_simp_tac (srw_ss()) [] + \\ srw_tac [] [] \\ full_simp_tac std_ss [RefBlock_def,ThunkBlock_def] + \\ imp_res_tac heap_store_rel_lemma + \\ res_tac \\ full_simp_tac (srw_ss()) [] + \\ ho_match_mp_tac v_inv_tf_restrict + \\ conj_tac + >- (match_mp_tac v_inv_SUBMAP + \\ full_simp_tac (srw_ss()) []) + \\ rw [] + \\ ho_match_mp_tac MEM_in_all_ts + \\ qexists_tac `a'` \\ rw [] + \\ rw [all_vs_def] \\ disj1_tac \\ disj2_tac + \\ qexistsl [`n`,`t`, `a'`] + \\ fs [lookup_insert] + \\ ho_match_mp_tac MEM_v_all_vs + \\ rw []) + THEN1 (imp_res_tac heap_store_rel_lemma \\ fs [Bytes_def] \\ metis_tac[]) + \\ `isSomeDataElement (heap_lookup (f ' n) heap)` by + (full_simp_tac std_ss [RefBlock_def] \\ EVAL_TAC + \\ simp_tac (srw_ss()) [] \\ NO_TAC) + \\ res_tac \\ full_simp_tac std_ss [] \\ simp_tac (srw_ss()) [RefBlock_def] + \\ qpat_x_assum `n IN FDOM f` ASSUME_TAC + \\ `n IN (domain refs)` by fs [domain_lookup] + \\ qpat_x_assum `lookup n refs = SOME (ValueArray l)` ASSUME_TAC + \\ full_simp_tac (srw_ss()) [] + \\ srw_tac [] [] \\ full_simp_tac std_ss [RefBlock_def] + \\ imp_res_tac heap_store_rel_lemma + \\ res_tac \\ full_simp_tac (srw_ss()) [] + \\ qpat_x_assum `EVERY2 PPP zs l` MP_TAC + \\ match_mp_tac EVERY2_IMP_EVERY2 + \\ full_simp_tac std_ss [] \\ simp_tac (srw_ss()) [] + \\ rpt strip_tac + \\ ho_match_mp_tac v_inv_tf_restrict + \\ conj_tac + >- (match_mp_tac v_inv_SUBMAP + \\ full_simp_tac (srw_ss()) []) + \\ rw [] + \\ ho_match_mp_tac MEM_in_all_ts + \\ qexists_tac `y` \\ rw [] + \\ rw [all_vs_def] \\ ntac 2 disj1_tac + \\ map_every qexists_tac [`n`,`l`] + \\ fs [lookup_insert] + \\ ho_match_mp_tac MEM_v_all_vs + \\ rw [] +QED + (* deref *) Definition heap_el_def: @@ -6200,7 +6435,61 @@ Theorem memory_rel_AllocThunk: (st |+ (EndOfHeap,Word w') |+ (TriggerGC,Word w1)) m1 dm ((RefPtr F new,make_ptr c (w' - curr) 0w 1)::vars) Proof - cheat + simp_tac std_ss [LET_THM] + \\ rewrite_tac [CONJ_ASSOC] + \\ once_rewrite_tac [CONJ_COMM] + \\ fs [memory_rel_def,PULL_EXISTS] \\ rw [] + \\ fs [word_ml_inv_def,PULL_EXISTS] \\ clean_tac + \\ drule (GEN_ALL new_thunk_thm) + \\ disch_then (qspecl_then [`new`, `ev`] strip_assume_tac) + \\ rfs [] \\ fs [] \\ clean_tac + \\ rewrite_tac [GSYM CONJ_ASSOC] + \\ once_rewrite_tac [METIS_PROVE [] ``b1 /\ b2 /\ b3 <=> b2 /\ b1 /\ b3:bool``] + \\ qmatch_asmsub_abbrev_tac `abs_ml_inv _ (v::l1) _ (v'::l2,_,_,_,_,_,_) _ _` + \\ `abs_ml_inv c ([v]++l1) (insert new (Thunk ev v) refs) + ([v']++l2,heap2,be,a,sp'-2,sp1,gens) limit ts` by gvs [] + \\ unabbrev_all_tac + \\ drule pop_thm \\ fs [] + \\ strip_tac \\ asm_exists_tac \\ fs [word_addr_def] + \\ fs [heap_in_memory_store_def,FLOOKUP_UPDATE] + \\ imp_res_tac heap_store_unused_IMP_length \\ fs [] + \\ fs [wordsTheory.n2w_sub,WORD_LEFT_ADD_DISTRIB] + \\ cheat + + (*\\ `LENGTH ws + 1 <= sp' + sp1` by decide_tac + \\ pop_assum mp_tac \\ simp_tac std_ss [LESS_EQ_EXISTS] + \\ strip_tac \\ clean_tac \\ fs [] + \\ fs [GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] + \\ fs [LIST_REL_APPEND_EQ] + \\ fs [WORD_LEFT_ADD_DISTRIB,get_addr_def,make_ptr_def,get_lowerbits_def] + \\ fs [bytes_in_word_mul_eq_shift] + \\ fs [GSYM bytes_in_word_mul_eq_shift,GSYM word_add_n2w] + \\ fs [heap_store_unused_def,el_length_def] + \\ fs [GSYM word_add_n2w,wordsTheory.n2w_sub,WORD_LEFT_ADD_DISTRIB] + \\ every_case_tac \\ fs [] + \\ imp_res_tac heap_lookup_SPLIT \\ fs [] \\ clean_tac + \\ full_simp_tac std_ss [APPEND,GSYM APPEND_ASSOC] + \\ fs [heap_store_lemma] \\ clean_tac \\ fs [] + \\ fs [word_heap_APPEND,word_heap_def,word_el_def,word_payload_def, + SEP_CLAUSES,word_heap_heap_expand,RefBlock_def,el_length_def, + heap_length_APPEND,heap_length_heap_expand] + \\ fs [word_list_exists_ADD |> Q.SPECL [`sp'`,`sp1`]] + \\ `make_header c 14w 1 = hd` by + (fs [encode_header_def] \\ every_case_tac \\ fs [] + \\ fs [WORD_MUL_LSL,word_mul_n2w,EXP_ADD] \\ NO_TAC) + \\ fs [] \\ drule encode_header_IMP \\ fs [] \\ strip_tac + \\ fs [SEP_CLAUSES,STAR_ASSOC] + \\ `LENGTH ws + 1 = LENGTH (Word hd::ws)` by fs [] + \\ full_simp_tac std_ss [] + \\ assume_tac store_list_thm + \\ SEP_F_TAC \\ strip_tac \\ fs [] + \\ fs [EVERY2_f_EQ] \\ clean_tac \\ fs [] + \\ fs [el_length_def,heap_length_APPEND,heap_length_heap_expand, + GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] + \\ fs [AC STAR_ASSOC STAR_COMM] \\ fs [STAR_ASSOC] + \\ pop_assum mp_tac \\ CONV_TAC (DEPTH_CONV ETA_CONV) + \\ fs [ADD1,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] + \\ fs [AC STAR_ASSOC STAR_COMM] \\ fs [STAR_ASSOC]*) QED Theorem memory_rel_write: From 0a526e75581f431d1938ce39dbe2b3879bfa1e27 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 31 Jul 2025 14:38:59 +0300 Subject: [PATCH 034/112] Prove all cheats in `data_to_word_memoryProof`; `AllocThunk` done in `data_to_word_assignProof` --- .../proofs/data_to_word_memoryProofScript.sml | 55 +++++++++---------- 1 file changed, 27 insertions(+), 28 deletions(-) diff --git a/compiler/backend/proofs/data_to_word_memoryProofScript.sml b/compiler/backend/proofs/data_to_word_memoryProofScript.sml index b7b430f290..f0220b7489 100644 --- a/compiler/backend/proofs/data_to_word_memoryProofScript.sml +++ b/compiler/backend/proofs/data_to_word_memoryProofScript.sml @@ -6453,10 +6453,7 @@ Proof \\ strip_tac \\ asm_exists_tac \\ fs [word_addr_def] \\ fs [heap_in_memory_store_def,FLOOKUP_UPDATE] \\ imp_res_tac heap_store_unused_IMP_length \\ fs [] - \\ fs [wordsTheory.n2w_sub,WORD_LEFT_ADD_DISTRIB] - \\ cheat - - (*\\ `LENGTH ws + 1 <= sp' + sp1` by decide_tac + \\ `2 <= sp' + sp1` by decide_tac \\ pop_assum mp_tac \\ simp_tac std_ss [LESS_EQ_EXISTS] \\ strip_tac \\ clean_tac \\ fs [] \\ fs [GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] @@ -6466,30 +6463,32 @@ Proof \\ fs [GSYM bytes_in_word_mul_eq_shift,GSYM word_add_n2w] \\ fs [heap_store_unused_def,el_length_def] \\ fs [GSYM word_add_n2w,wordsTheory.n2w_sub,WORD_LEFT_ADD_DISTRIB] - \\ every_case_tac \\ fs [] - \\ imp_res_tac heap_lookup_SPLIT \\ fs [] \\ clean_tac - \\ full_simp_tac std_ss [APPEND,GSYM APPEND_ASSOC] - \\ fs [heap_store_lemma] \\ clean_tac \\ fs [] - \\ fs [word_heap_APPEND,word_heap_def,word_el_def,word_payload_def, - SEP_CLAUSES,word_heap_heap_expand,RefBlock_def,el_length_def, - heap_length_APPEND,heap_length_heap_expand] - \\ fs [word_list_exists_ADD |> Q.SPECL [`sp'`,`sp1`]] - \\ `make_header c 14w 1 = hd` by - (fs [encode_header_def] \\ every_case_tac \\ fs [] - \\ fs [WORD_MUL_LSL,word_mul_n2w,EXP_ADD] \\ NO_TAC) - \\ fs [] \\ drule encode_header_IMP \\ fs [] \\ strip_tac - \\ fs [SEP_CLAUSES,STAR_ASSOC] - \\ `LENGTH ws + 1 = LENGTH (Word hd::ws)` by fs [] - \\ full_simp_tac std_ss [] - \\ assume_tac store_list_thm - \\ SEP_F_TAC \\ strip_tac \\ fs [] - \\ fs [EVERY2_f_EQ] \\ clean_tac \\ fs [] - \\ fs [el_length_def,heap_length_APPEND,heap_length_heap_expand, - GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] - \\ fs [AC STAR_ASSOC STAR_COMM] \\ fs [STAR_ASSOC] - \\ pop_assum mp_tac \\ CONV_TAC (DEPTH_CONV ETA_CONV) - \\ fs [ADD1,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] - \\ fs [AC STAR_ASSOC STAR_COMM] \\ fs [STAR_ASSOC]*) + \\ every_case_tac \\fs [] + \\ ( + imp_res_tac heap_lookup_SPLIT \\ fs [] \\ clean_tac + \\ full_simp_tac std_ss [APPEND,GSYM APPEND_ASSOC] + \\ fs [heap_store_lemma] \\ clean_tac \\ fs [] + \\ fs [word_heap_APPEND,word_heap_def,word_el_def,word_payload_def, + SEP_CLAUSES,word_heap_heap_expand,ThunkBlock_def,el_length_def, + heap_length_APPEND,heap_length_heap_expand,thunk_tag_to_bits_def] + \\ fs [word_list_exists_ADD |> Q.SPECL [`sp'`,`sp1`]] + \\ qmatch_goalsub_abbrev_tac `make_header c nn 1` + \\ `make_header c nn 1 = hd` by + (fs [Abbr`nn`,encode_header_def] \\ every_case_tac \\ fs [] + \\ fs [WORD_MUL_LSL,word_mul_n2w,EXP_ADD] \\ NO_TAC) + \\ fs [Abbr`nn`] \\ drule encode_header_IMP \\ fs [] \\ strip_tac + \\ fs [SEP_CLAUSES,STAR_ASSOC] + \\ `2 = LENGTH [Word hd; word_addr c v']` by fs [] + \\ full_simp_tac std_ss [] + \\ assume_tac store_list_thm + \\ SEP_F_TAC \\ strip_tac \\ fs [] + \\ fs [EVERY2_f_EQ] \\ clean_tac \\ fs [] + \\ fs [el_length_def,heap_length_APPEND,heap_length_heap_expand, + GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] + \\ fs [AC STAR_ASSOC STAR_COMM] \\ fs [STAR_ASSOC] + \\ pop_assum mp_tac \\ CONV_TAC (DEPTH_CONV ETA_CONV) + \\ fs [ADD1,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] + \\ fs [AC STAR_ASSOC STAR_COMM] \\ fs [STAR_ASSOC]) QED Theorem memory_rel_write: From 8dcb8f2fd9b48771fc2a24da94bdb87e77bd2938 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Fri, 1 Aug 2025 15:34:34 +0300 Subject: [PATCH 035/112] Progress on `UpdateThunk` in `dat_to_word*` --- .../proofs/data_to_word_assignProofScript.sml | 73 ++- .../proofs/data_to_word_memoryProofScript.sml | 443 +++++++++++++++++- 2 files changed, 513 insertions(+), 3 deletions(-) diff --git a/compiler/backend/proofs/data_to_word_assignProofScript.sml b/compiler/backend/proofs/data_to_word_assignProofScript.sml index ca8cae7ec9..90e998c67a 100644 --- a/compiler/backend/proofs/data_to_word_assignProofScript.sml +++ b/compiler/backend/proofs/data_to_word_assignProofScript.sml @@ -258,6 +258,13 @@ Proof match_mp_tac memory_rel_rearrange \\ fs [] \\ rw [] \\ fs [] QED +Theorem reorder_2_lemma: + memory_rel c be ts x.refs x.space t.store t.memory t.mdomain (x1::x2::xs) ==> + memory_rel c be ts x.refs x.space t.store t.memory t.mdomain (x2::x1::xs) +Proof + match_mp_tac memory_rel_rearrange \\ fs [] \\ rw [] \\ fs [] +QED + Theorem evaluate_StoreEach = Q.prove(` !xs ys t offset m1. store_list (a + offset) ys t.memory t.mdomain = SOME m1 /\ @@ -5037,7 +5044,71 @@ QED Theorem assign_UpdateThunk: (∃ev. op = ThunkOp (UpdateThunk ev)) ==> ^assign_thm_goal Proof - cheat + rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs [] + \\ `t.termdep <> 0` by fs[] + \\ gvs [dataLangTheory.op_requires_names_def, + dataLangTheory.op_space_reset_def] + \\ rpt_drule0 state_rel_cut_IMP + \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac + \\ imp_res_tac get_vars_IMP_LENGTH \\ fs [] + \\ gvs [do_app,allowed_op_def,AllCaseEqs()] + \\ imp_res_tac state_rel_get_vars_IMP + \\ fs [bvlSemTheory.Unit_def] \\ rveq + \\ fs [GSYM bvlSemTheory.Unit_def] \\ rveq + \\ fs [assign_def] \\ eval_tac \\ fs [state_rel_thm] + \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] + \\ drule0 (memory_rel_get_vars_IMP |> GEN_ALL) + \\ disch_then drule0 \\ fs [] + \\ Cases_on `args` \\ gvs [] + \\ Cases_on `t'` \\ gvs [] + \\ Cases_on `t''` \\ gvs [] + \\ Cases_on `ws` \\ gvs [] + \\ Cases_on `t'` \\ gvs [] + \\ imp_res_tac get_vars_2_IMP \\ fs [] + \\ strip_tac + \\ drule0 reorder_2_lemma \\ strip_tac + \\ reverse $ Cases_on `ev` \\ gvs [] + >- ( + drule0 (memory_rel_UpdateThunk |> GEN_ALL) \\ fs [] + \\ strip_tac \\ clean_tac + \\ `word_exp t (real_addr c (adjust_var h)) = SOME (Word x')` by + metis_tac [get_real_offset_lemma,get_real_addr_lemma] + \\ fs [] \\ eval_tac \\ fs [EVAL ``word_exp s1 Unit``] + \\ fs [wordSemTheory.mem_store_def] + \\ fs [lookup_insert,adjust_var_11] + \\ rw [] \\ fs [option_le_max_right] + \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] + \\ match_mp_tac memory_rel_insert \\ fs [] + \\ match_mp_tac memory_rel_Unit \\ fs [] + \\ first_x_assum (fn th => mp_tac th THEN match_mp_tac memory_rel_rearrange) + \\ rw [] \\ gvs []) + \\ TOP_CASE_TAC \\ gvs [] + >- ( + fs[encode_header_def] + \\ fs[encode_header_def, state_rel_def, good_dimindex_def, limits_inv_def, + dimword_def, memory_rel_def, heap_in_memory_store_def, + consume_space_def, arch_size_def] + \\ rfs[NOT_LESS]) + \\ drule0 (memory_rel_UpdateThunk' |> GEN_ALL) \\ fs [] + \\ disch_then drule + \\ strip_tac \\ clean_tac + \\ `word_exp t (real_addr c (adjust_var h)) = SOME (Word x'')` by + metis_tac [get_real_offset_lemma,get_real_addr_lemma] + \\ fs [list_Seq_def] \\ eval_tac \\ fs [EVAL ``word_exp s1 Unit``] + \\ fs [wordSemTheory.mem_store_def] + \\ fs [lookup_insert,adjust_var_11] + \\ rw [] + >- simp [option_le_max_right] + \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] + \\ match_mp_tac memory_rel_insert \\ fs [] + \\ match_mp_tac memory_rel_Unit \\ fs [UPDATE_LIST_THM] + \\ first_x_assum (fn th => mp_tac th THEN match_mp_tac memory_rel_rearrange) + \\ rw [] \\ gvs [] + \\ ntac 2 disj2_tac \\ ntac 2 disj1_tac \\ gvs [] + \\ gvs [join_env_def, MEM_MAP, MEM_FILTER] + \\ rpt (pairarg_tac \\ gvs []) + \\ qexists `(n,v)` \\ gvs [] + \\ gvs [MEM_toAList,lookup_inter_alt,lookup_insert,AllCaseEqs()] QED Theorem assign_ConfigGC: diff --git a/compiler/backend/proofs/data_to_word_memoryProofScript.sml b/compiler/backend/proofs/data_to_word_memoryProofScript.sml index f0220b7489..c8e4614632 100644 --- a/compiler/backend/proofs/data_to_word_memoryProofScript.sml +++ b/compiler/backend/proofs/data_to_word_memoryProofScript.sml @@ -2924,8 +2924,8 @@ Proof QED Triviality reachable_refs_Thunk_UPDATE: - reachable_refs (v::RefPtr F ptr::stack) (insert ptr (Thunk ev v) refs) n ==> - reachable_refs (v::RefPtr F ptr::stack) refs n + reachable_refs (v::RefPtr b ptr::stack) (insert ptr (Thunk ev v) refs) n ==> + reachable_refs (v::RefPtr b ptr::stack) refs n Proof full_simp_tac std_ss [reachable_refs_def] \\ rpt strip_tac \\ Cases_on `?m. MEM m (get_refs (Block 0 ARB [v])) /\ @@ -3057,6 +3057,7 @@ Proof \\ full_simp_tac std_ss [heap_store_RefBlock_thm] \\ strip_tac THEN1 (full_simp_tac std_ss [RefBlock_inv_def] + \\ rw [] \\ full_simp_tac std_ss [heap_lookup_RefBlock_lemma] \\ full_simp_tac std_ss [isRefBlock_def] \\ metis_tac []) \\ strip_tac THEN1 (full_simp_tac std_ss [heap_lookup_PREFIX]) @@ -3134,6 +3135,154 @@ Proof THEN1 (full_simp_tac (srw_ss()) [v_inv_def,SUBMAP_DEF]) QED +Definition isThunkBlock_def: + isThunkBlock x = ?ev v. x = ThunkBlock ev v +End + +Definition ThunkBlock_inv_def: + ThunkBlock_inv heap heap2 <=> + (!n x. (heap_lookup n heap = SOME x) /\ ~(isThunkBlock x) ==> + (heap_lookup n heap2 = SOME x)) /\ + (!n x. (heap_lookup n heap2 = SOME x) /\ ~(isThunkBlock x) ==> + (heap_lookup n heap = SOME x)) +End + +Theorem heap_store_ThunkBlock_thm: + ∀ha. + (heap_store (heap_length ha) [ThunkBlock ev1 v1] (ha ++ ThunkBlock ev2 v2::hb) = + (ha ++ ThunkBlock ev1 v1::hb,T)) +Proof + Induct \\ full_simp_tac (srw_ss()) [heap_store_def,heap_length_def] + >- ( + full_simp_tac std_ss [ThunkBlock_def,el_length_def] + \\ strip_tac) + \\ rpt strip_tac \\ full_simp_tac std_ss [] + \\ `~(el_length h + SUM (MAP el_length ha) < el_length h) /\ el_length h <> 0` by + (Cases_on `h` \\ full_simp_tac std_ss [el_length_def] \\ DECIDE_TAC) + \\ full_simp_tac std_ss [LET_DEF] +QED + +Triviality heap_lookup_ThunkBlock_lemma: + (heap_lookup n (ha ++ ThunkBlock ev v::hb) = SOME x) = + if n < heap_length ha then + (heap_lookup n ha = SOME x) + else if n = heap_length ha then + (x = ThunkBlock ev v) + else if heap_length ha + 2 <= n then + (heap_lookup (n - heap_length ha - 2) hb = SOME x) + else F +Proof + Cases_on `n < heap_length ha` \\ full_simp_tac std_ss [LESS_IMP_heap_lookup] + \\ full_simp_tac std_ss [NOT_LESS_IMP_heap_lookup] + \\ full_simp_tac std_ss [heap_lookup_def] + \\ Cases_on `n <= heap_length ha` \\ full_simp_tac std_ss [] + THEN1 (`heap_length ha = n` by DECIDE_TAC \\ full_simp_tac std_ss [] \\ metis_tac []) + \\ `heap_length ha <> n` by DECIDE_TAC \\ full_simp_tac std_ss [] + \\ `0 < el_length (ThunkBlock ev v)` + by (full_simp_tac std_ss [el_length_def,ThunkBlock_def] >> decide_tac) + \\ full_simp_tac std_ss [] \\ srw_tac [] [] + \\ full_simp_tac std_ss [el_length_def,ThunkBlock_def,NOT_LESS] +QED + +Triviality heap_store_ThunkBlock: + (heap_lookup n heap = SOME (ThunkBlock NotEvaluated y)) ⇒ + ∃heap2. + heap_store n [ThunkBlock NotEvaluated h] heap = (heap2,T) ∧ + ThunkBlock_inv heap heap2 ∧ + (heap_lookup n heap2 = SOME (ThunkBlock NotEvaluated h)) ∧ + (heap_length heap2 = heap_length heap) ∧ + (FILTER isForwardPointer heap2 = FILTER isForwardPointer heap) ∧ + (∀xs l d. + MEM (DataElement xs l d) heap2 ⇒ + (DataElement xs l d = ThunkBlock NotEvaluated h) ∨ + MEM (DataElement xs l d) heap) ∧ + (∀a. isSomeDataElement (heap_lookup a heap2) = + isSomeDataElement (heap_lookup a heap)) ∧ + (∀m x. m <> n ∧ (heap_lookup m heap = SOME x) ⇒ + (heap_lookup m heap2 = SOME x)) +Proof + rpt strip_tac \\ imp_res_tac heap_lookup_SPLIT + \\ full_simp_tac std_ss [heap_store_ThunkBlock_thm] + \\ strip_tac THEN1 + (full_simp_tac std_ss [ThunkBlock_inv_def] + \\ full_simp_tac std_ss [heap_lookup_ThunkBlock_lemma] + \\ full_simp_tac std_ss [isThunkBlock_def] \\ metis_tac []) + \\ strip_tac THEN1 (full_simp_tac std_ss [heap_lookup_PREFIX]) + \\ strip_tac THEN1 (full_simp_tac (srw_ss()) + [heap_length_APPEND,heap_length_def,ThunkBlock_def,el_length_def]) + \\ strip_tac THEN1 + (full_simp_tac (srw_ss()) [rich_listTheory.FILTER_APPEND,FILTER, + isForwardPointer_def,ThunkBlock_def]) + \\ strip_tac THEN1 + (full_simp_tac (srw_ss()) [MEM,MEM_APPEND,ThunkBlock_def] \\ metis_tac []) + \\ strip_tac THEN1 + (full_simp_tac std_ss [isSomeDataElement_def,heap_lookup_ThunkBlock_lemma] + \\ full_simp_tac std_ss [ThunkBlock_def] \\ metis_tac []) + \\ full_simp_tac std_ss [isSomeDataElement_def,heap_lookup_ThunkBlock_lemma] + \\ metis_tac [] +QED + +Triviality NOT_isThunkBlock: + ~(isThunkBlock (Bignum x)) /\ + ~(isThunkBlock (Word64Rep a w)) /\ + ~(isThunkBlock (DataElement xs (LENGTH xs) (BlockTag n,[]))) +Proof + simp_tac (srw_ss()) [isThunkBlock_def,ThunkBlock_def,Bignum_def] + \\ Cases_on`a` \\ rw[] + \\ TRY pairarg_tac \\ fs[] + \\ EVAL_TAC \\ rw[] +QED + +Triviality v_inv_Thunk: + ThunkBlock_inv heap heap2 ==> + !x h f tf. (v_inv conf x (h,f,tf,heap2) = v_inv conf x (h,f,tf,heap)) +Proof + strip_tac \\ completeInduct_on `v_size x` \\ NTAC 3 strip_tac + \\ full_simp_tac std_ss [PULL_FORALL] \\ Cases_on `x` THEN1 + (full_simp_tac std_ss [v_inv_def] \\ srw_tac [] [] + \\ rpt strip_tac \\ full_simp_tac std_ss [] + \\ full_simp_tac std_ss [ThunkBlock_inv_def] + \\ metis_tac [NOT_isThunkBlock]) + THEN1 ( + fs[v_inv_def,ThunkBlock_inv_def] + \\ metis_tac[NOT_isThunkBlock] ) + THEN1 (full_simp_tac (srw_ss()) [v_inv_def,ADDR_APPLY_def,BlockRep_def] + \\ Cases_on `l = []` \\ full_simp_tac std_ss [] + \\ full_simp_tac (srw_ss()) [v_inv_def,ADDR_APPLY_def,BlockRep_def] + \\ rpt strip_tac + \\ full_simp_tac std_ss [EVERY2_EVERY,LENGTH_ADDR_MAP,EVERY_MEM,FORALL_PROD] + \\ rpt strip_tac \\ EQ_TAC \\ rpt strip_tac + THEN1 + (qpat_x_assum `LENGTH l = LENGTH xs` ASSUME_TAC + \\ full_simp_tac (srw_ss()) [MEM_ZIP,LENGTH_ADDR_MAP,PULL_EXISTS] + \\ `heap_lookup ptr heap = + SOME (DataElement xs (LENGTH xs) (BlockTag n,[]))` by + metis_tac [ThunkBlock_inv_def,NOT_isThunkBlock] + \\ full_simp_tac (srw_ss()) [MEM_ZIP] + \\ rpt strip_tac + \\ Q.MATCH_ASSUM_RENAME_TAC `t < LENGTH xs` \\ res_tac + \\ `MEM (EL t l) l` by (full_simp_tac std_ss [MEM_EL] \\ metis_tac []) + \\ imp_res_tac MEM_IMP_v_size + \\ last_x_assum $ qspec_then ‘EL t l’ mp_tac \\ gvs [] + \\ metis_tac []) + THEN1 + (qpat_x_assum `LENGTH l = LENGTH xs` ASSUME_TAC + \\ full_simp_tac (srw_ss()) [MEM_ZIP,LENGTH_ADDR_MAP,PULL_EXISTS] + \\ `heap_lookup ptr heap2 = + SOME (DataElement xs (LENGTH xs) (BlockTag n,[]))` by + metis_tac [ThunkBlock_inv_def,NOT_isThunkBlock] + \\ full_simp_tac (srw_ss()) [MEM_ZIP] + \\ rpt strip_tac + \\ Q.MATCH_ASSUM_RENAME_TAC `t < LENGTH xs` \\ res_tac + \\ `MEM (EL t l) l` by (full_simp_tac std_ss [MEM_EL] \\ metis_tac []) + \\ `MEM (EL t l) l` by (full_simp_tac std_ss [MEM_EL] \\ metis_tac []) + \\ imp_res_tac MEM_IMP_v_size + \\ last_x_assum $ qspec_then ‘EL t l’ mp_tac \\ gvs [] + \\ metis_tac [])) + THEN1 (full_simp_tac std_ss [v_inv_def]) + THEN1 (full_simp_tac (srw_ss()) [v_inv_def,SUBMAP_DEF]) +QED + val heap_lookup_heap_split = prove( ``!heap a b h1 h2 x. heap_split a heap = SOME (h1,h2) /\ @@ -3192,6 +3341,17 @@ val data_up_to_alt = prove( \\ rpt (CASE_TAC \\ fs []) \\ rw [] \\ eq_tac \\ rw []); +val update_thunk_gen_state_ok = prove( + ``heap_store b [ThunkBlock NotEvaluated t1] heap = (heap2,T) ∧ a <= b ∧ + gen_state_ok a (a + (sp + sp1)) heap gens ⇒ + gen_state_ok a (a + (sp + sp1)) heap2 gens``, + Cases_on `gens` \\ fs [gen_state_ok_def] + \\ fs [EVERY_MEM] \\ rpt strip_tac \\ fs [] \\ res_tac + \\ fs [gen_start_ok_def] \\ rpt strip_tac + \\ drule (GEN_ALL heap_split_heap_store) + \\ disch_then drule \\ fs [] \\ strip_tac + \\ fs [] \\ rpt strip_tac \\ res_tac \\ fs []) |> GEN_ALL; + Theorem data_up_to_heap_store: !heap a b heap2 y. data_up_to a heap /\ heap_store b [y] heap = (heap2,T) /\ @@ -3528,6 +3688,163 @@ Proof \\ simp [EL_MEM]) QED +Definition thunk_deref_def: + (thunk_deref a heap = + case heap_lookup a heap of + | SOME (DataElement xs l (ThunkTag NotEvaluated,[])) => SOME xs + | _ => NONE) +End + +Theorem update_thunk_thm: + abs_ml_inv conf (h::RefPtr b ptr::stack) refs + (roots,heap,be,a,sp,sp1,gens) limit ts ∧ + (lookup ptr refs = SOME (Thunk NotEvaluated v)) ⇒ + ?p r roots2 v1 heap2 u. + (roots = r :: Pointer p u :: roots2) ∧ + (thunk_deref p heap = SOME v1) ∧ + (heap_store p [ThunkBlock NotEvaluated r] heap = (heap2,T)) ∧ + abs_ml_inv conf (h::(RefPtr b ptr)::stack) + (insert ptr (Thunk NotEvaluated h) refs) + (roots,heap2,be,a,sp,sp1,gens) limit ts +Proof + simp_tac std_ss [abs_ml_inv_def] + \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def] + \\ gvs [GSYM CONS_APPEND] + \\ full_simp_tac std_ss [v_inv_def] + \\ Cases_on `x'` \\ gvs [] + \\ full_simp_tac std_ss [] + \\ `reachable_refs (h::RefPtr b ptr::stack) refs ptr` by + (full_simp_tac std_ss [reachable_refs_def] \\ qexists_tac `RefPtr b ptr` + \\ full_simp_tac (srw_ss()) [get_refs_def]) + \\ res_tac \\ POP_ASSUM MP_TAC \\ simp_tac std_ss [Once bc_ref_inv_def] + \\ Cases_on `FLOOKUP f ptr` \\ full_simp_tac (srw_ss()) [] + \\ rpt strip_tac \\ gvs [] + \\ gvs [FLOOKUP_DEF] + \\ `thunk_deref (f ' ptr) heap = SOME [z]` by ( + fs[thunk_deref_def,ThunkBlock_def,FLOOKUP_DEF] ) + \\ imp_res_tac heap_store_ThunkBlock + \\ POP_ASSUM (MP_TAC o Q.SPEC `x`) + \\ full_simp_tac std_ss [] \\ simp[LENGTH_LUPDATE] + \\ strip_tac \\ full_simp_tac std_ss [] + \\ full_simp_tac (srw_ss()) [FLOOKUP_DEF] + \\ strip_tac THEN1 + (full_simp_tac std_ss [roots_ok_def] \\ fs [] \\ metis_tac []) + \\ strip_tac THEN1 + (full_simp_tac std_ss [heap_ok_def] \\ rpt strip_tac \\ res_tac + \\ full_simp_tac (srw_ss()) [ThunkBlock_def] \\ srw_tac [] [] + \\ Q.ABBREV_TAC `p1 = ptr'` \\ POP_ASSUM (K ALL_TAC) + \\ Cases_on `p1 = f ' ptr` \\ full_simp_tac std_ss [] + THEN1 (EVAL_TAC \\ simp_tac std_ss []) + \\ full_simp_tac std_ss [roots_ok_def,MEM_APPEND,MEM] + \\ imp_res_tac MEM_LUPDATE_E >> fs[]) + \\ strip_tac THEN1 + (fs [gc_kind_inv_def] \\ every_case_tac \\ fs[] + \\ conj_tac THEN1 + (match_mp_tac update_thunk_gen_state_ok + \\ asm_exists_tac \\ fs [] + \\ rpt_drule heap_lookup_heap_split + \\ IF_CASES_TAC \\ fs [] \\ strip_tac + \\ fs [EVERY_MEM] \\ res_tac + \\ fs [ThunkBlock_def,isRef_def,isMutTag_def]) + \\ drule heap_split_heap_length \\ strip_tac \\ qpat_x_assum `_ ++ _ = _` (assume_tac o GSYM) + \\ fs[] \\ fs[heap_lookup_APPEND] \\ every_case_tac \\ fs[] \\ rfs[] + \\ qpat_x_assum `heap_lookup _ _ = SOME (ThunkBlock NotEvaluated z)` assume_tac + \\ drule heap_lookup_SPLIT \\ strip_tac \\ fs[] \\ rveq \\ fs[] + THEN1 fs[ThunkBlock_def,isRef_def,isMutTag_def] + \\ qpat_x_assum `heap_store _ _ _ = _` mp_tac + \\ SIMP_TAC std_ss [GSYM APPEND_ASSOC,APPEND,heap_store_lemma] \\ disch_then (assume_tac o GSYM) + \\ fs[] + \\ `f ' ptr = heap_length(h1 ++ ha)` by fs[heap_length_APPEND] + \\ fs[heap_store_lemma] + \\ qpat_x_assum `heap_length h1 = _` (assume_tac o GSYM) + \\ fs[] + \\ SIMP_TAC std_ss [GSYM APPEND_ASSOC,gen_gc_partialTheory.heap_split_length] + \\ fs[isRef_def,ThunkBlock_def]) + \\ strip_tac THEN1 + (full_simp_tac std_ss [unused_space_inv_def] \\ rpt strip_tac + \\ res_tac \\ Cases_on `a = f ' ptr` \\ full_simp_tac (srw_ss()) [] + THEN1 full_simp_tac (srw_ss()) [ThunkBlock_def] + \\ imp_res_tac data_up_to_heap_store \\ fs []) + \\ qexists_tac `f` \\ full_simp_tac std_ss [] + \\ qexists_tac `DRESTRICT tf (all_ts (insert ptr (Thunk NotEvaluated h) refs) + (h::RefPtr b ptr::stack))` + \\ full_simp_tac std_ss [] + \\ MP_TAC v_inv_Thunk + \\ full_simp_tac std_ss [] \\ rpt strip_tac + THEN1 (fs [SUBSET_DEF]) + THEN1 (fs [INJ_DEF,DRESTRICT_DEF]) + THEN1 (fs [SUBSET_DEF,DRESTRICT_DEF]) + THEN1 (fs [SUBSET_DEF,DRESTRICT_DEF,SUBSET_DEF,IN_INTER]) + >- (ho_match_mp_tac v_inv_tf_restrict + \\ rw [] + \\ ho_match_mp_tac MEM_in_all_ts + \\ goal_assum $ drule_at Any \\ gvs [] + \\ ho_match_mp_tac MEM_stack_all_vs + \\ rw [EL_MEM]) + >- (match_mp_tac EVERY2_MEM_MONO + \\ imp_res_tac LIST_REL_APPEND_IMP + \\ first_assum(part_match_exists_tac(last o strip_conj) o concl) + \\ simp[FORALL_PROD] \\ rw[] + \\ ho_match_mp_tac v_inv_tf_restrict + \\ rw [] + \\ ho_match_mp_tac MEM_in_all_ts + \\ qexists_tac `p_1` \\ rw [] + \\ ho_match_mp_tac MEM_stack_all_vs + \\ qmatch_asmsub_abbrev_tac `MEM (_,_) (ZIP (l,_))` + \\ drule MEM_ZIP2 \\ rw [] + \\ rw [EL_MEM]) + \\ Cases_on `n = ptr` THEN1 ( + full_simp_tac (srw_ss()) [bc_ref_inv_def] + \\ srw_tac [] [] \\ full_simp_tac (srw_ss()) [FLOOKUP_DEF,ThunkBlock_def] + \\ ho_match_mp_tac v_inv_tf_restrict + \\ rw [] + \\ ho_match_mp_tac MEM_in_all_ts + \\ goal_assum $ drule_at Any \\ gvs [] + \\ ho_match_mp_tac MEM_stack_all_vs + \\ rw [EL_MEM]) + \\ `reachable_refs (h::RefPtr b ptr::stack) refs n` by ( + match_mp_tac (GEN_ALL (MP_CANON reachable_refs_Thunk_UPDATE)) + \\ metis_tac []) + \\ full_simp_tac (srw_ss()) [bc_ref_inv_def] + \\ res_tac + \\ Cases_on `FLOOKUP f n` \\ full_simp_tac (srw_ss()) [] + \\ Cases_on `lookup n refs` \\ full_simp_tac (srw_ss()) [] + \\ full_simp_tac (srw_ss()) [FLOOKUP_DEF,FAPPLY_FUPDATE_THM] \\ rw [lookup_insert] + \\ Cases_on `x''` \\ full_simp_tac (srw_ss()) [] + >- (qexists_tac `zs` \\ conj_tac + >- (first_x_assum ho_match_mp_tac \\ rw [] \\ CCONTR_TAC \\ metis_tac [INJ_DEF]) + >- (match_mp_tac EVERY2_MEM_MONO + \\ imp_res_tac LIST_REL_APPEND_IMP + \\ first_assum(part_match_exists_tac(last o strip_conj) o concl) + \\ simp[FORALL_PROD] \\ rw[] + \\ ho_match_mp_tac v_inv_tf_restrict + \\ rw [] + \\ ho_match_mp_tac MEM_in_all_ts + \\ qexists_tac `p_2` \\ rw [] + \\ rw [all_vs_def] \\ ntac 2 disj1_tac + \\ map_every qexists_tac [`n`,`l`] + \\ rw [lookup_insert] + \\ ho_match_mp_tac MEM_v_all_vs + \\ drule MEM_ZIP2 \\ rw [] + \\ rw [EL_MEM])) + >- (full_simp_tac (srw_ss()) [INJ_DEF] \\ metis_tac []) + >- ( + qexists `z'` \\ conj_tac + >- ( + first_x_assum ho_match_mp_tac \\ rw [] + \\ CCONTR_TAC + \\ metis_tac [INJ_DEF]) + \\ ho_match_mp_tac v_inv_tf_restrict + \\ rw [] + \\ ho_match_mp_tac MEM_in_all_ts + \\ goal_assum $ drule_at Any \\ gvs [] + \\ rw [all_vs_def] \\ disj1_tac \\ disj2_tac + \\ qexistsl [`n`, `t`, `a'`] \\ gvs [] + \\ simp [lookup_insert] + \\ ho_match_mp_tac MEM_v_all_vs + \\ simp [EL_MEM]) +QED + (* update byte ref *) Theorem LENGTH_write_bytes[simp]: @@ -5849,6 +6166,128 @@ Proof \\ SEP_W_TAC \\ fs [AC STAR_ASSOC STAR_COMM] QED +Theorem memory_rel_UpdateThunk: + memory_rel c be ts refs sp st m dm + ((h,w)::(RefPtr bl nn,ptr)::vars) /\ + lookup nn refs = SOME (Thunk NotEvaluated v) /\ + good_dimindex (:'a) ==> + ?ptr_w x:'a word. + ptr = Word ptr_w /\ + get_real_addr c st ptr_w = SOME x /\ + (x + bytes_in_word) IN dm /\ + memory_rel c be ts (insert nn (Thunk NotEvaluated h) refs) sp st + ((x + bytes_in_word =+ w) m) dm + ((h,w)::(RefPtr bl nn,ptr)::vars) +Proof + rewrite_tac [CONJ_ASSOC] + \\ once_rewrite_tac [CONJ_COMM] + \\ fs [memory_rel_def,PULL_EXISTS] \\ rw [] + \\ fs [word_ml_inv_def,PULL_EXISTS] \\ clean_tac + \\ rpt_drule (update_thunk_thm |> GEN_ALL) + \\ fs [LENGTH_EQ_1,PULL_EXISTS] + \\ rpt strip_tac \\ fs [] \\ clean_tac + \\ rewrite_tac [GSYM CONJ_ASSOC] + \\ once_rewrite_tac [METIS_PROVE [] ``b1 /\ b2 /\ b3 <=> b2 /\ b1 /\ b3:bool``] + \\ asm_exists_tac \\ fs [word_addr_def] + \\ fs [thunk_deref_def] \\ every_case_tac \\ fs [] \\ clean_tac + \\ fs [heap_in_memory_store_def] + \\ rpt_drule get_real_addr_get_addr \\ fs [] + \\ disch_then kall_tac + \\ `LENGTH l = 1 ∧ n = 1` by + (qpat_x_assum `abs_ml_inv _ _ _ _ _ _` kall_tac + \\ fs [abs_ml_inv_def,bc_stack_ref_inv_def,v_inv_def] + \\ clean_tac + \\ fs [word_heap_APPEND,word_heap_def,word_el_def,word_payload_def] + \\ `reachable_refs (h::RefPtr bl nn::MAP FST vars) refs nn` by ( + fs [reachable_refs_def] \\ qexists_tac `RefPtr bl nn` \\ fs [] + \\ fs [get_refs_def] \\ NO_TAC) \\ res_tac + \\ pop_assum mp_tac + \\ simp_tac std_ss [bc_ref_inv_def] + \\ fs [FLOOKUP_DEF,ThunkBlock_def] + \\ rw [] \\ simp [LENGTH]) + \\ fs [] \\ fs [get_real_offset_thm] + \\ Cases_on `l` \\ gvs [] + \\ fs [GSYM ThunkBlock_def] + \\ imp_res_tac heap_lookup_SPLIT \\ fs [] \\ clean_tac + \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND] + \\ fs [heap_store_ThunkBlock_thm,LENGTH_LUPDATE] \\ clean_tac + \\ fs [heap_length_APPEND] + \\ fs [heap_length_def,el_length_def,ThunkBlock_def] + \\ fs [word_heap_APPEND,word_heap_def,word_el_def,word_payload_def] + \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR,SEP_CLAUSES] + \\ fs [word_list_def,SEP_CLAUSES] + \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND,LUPDATE_LENGTH] + \\ fs [word_list_def,word_list_APPEND,SEP_CLAUSES,heap_length_def] + \\ fs [el_length_def,SUM_APPEND] + \\ fs [GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] + \\ SEP_R_TAC \\ fs [] + \\ SEP_W_TAC \\ fs [AC STAR_ASSOC STAR_COMM] +QED + +Theorem memory_rel_UpdateThunk': + memory_rel c be ts refs sp st m dm + ((h,w)::(RefPtr bl nn,ptr)::vars) /\ + lookup nn refs = SOME (Thunk NotEvaluated v) /\ + encode_header c hx hy = SOME hdr /\ + good_dimindex (:'a) ==> + ?ptr_w x:'a word. + ptr = Word ptr_w /\ + get_real_addr c st ptr_w = SOME x /\ + x IN dm /\ (x + bytes_in_word) IN dm /\ + memory_rel c be ts (insert nn (Thunk Evaluated h) refs) sp st + (m =++ [x, Word hdr; x + bytes_in_word,w]) dm + ((h,w)::(RefPtr bl nn,ptr)::vars) +Proof + rewrite_tac [CONJ_ASSOC] + \\ once_rewrite_tac [CONJ_COMM] + \\ fs [memory_rel_def,PULL_EXISTS] \\ rw [] + \\ fs [word_ml_inv_def,PULL_EXISTS] \\ clean_tac + \\ rpt_drule (update_thunk_thm |> GEN_ALL) + \\ fs [LENGTH_EQ_1,PULL_EXISTS] + \\ rpt strip_tac \\ fs [] \\ clean_tac + \\ rewrite_tac [GSYM CONJ_ASSOC] + \\ once_rewrite_tac [METIS_PROVE [] ``b1 /\ b2 /\ b3 <=> b2 /\ b1 /\ b3:bool``] + \\ `abs_ml_inv c (h::RefPtr bl nn::MAP FST vars) + (insert nn (Thunk Evaluated h) refs) + (v'::Pointer p u::xs',heap2,be,a,sp',sp1,gens) limit ts` by cheat + \\ pop_assum mp_tac \\ pop_assum kall_tac \\ strip_tac + \\ asm_exists_tac \\ fs [word_addr_def] + \\ fs [thunk_deref_def] \\ every_case_tac \\ fs [] \\ clean_tac + \\ fs [heap_in_memory_store_def] + \\ rpt_drule get_real_addr_get_addr \\ fs [] + \\ disch_then kall_tac + \\ `LENGTH l = 1 ∧ n = 1` by + (qpat_x_assum `abs_ml_inv _ _ _ _ _ _` kall_tac + \\ fs [abs_ml_inv_def,bc_stack_ref_inv_def,v_inv_def] + \\ clean_tac + \\ fs [word_heap_APPEND,word_heap_def,word_el_def,word_payload_def] + \\ `reachable_refs (h::RefPtr bl nn::MAP FST vars) refs nn` by ( + fs [reachable_refs_def] \\ qexists_tac `RefPtr bl nn` \\ fs [] + \\ fs [get_refs_def] \\ NO_TAC) \\ res_tac + \\ pop_assum mp_tac + \\ simp_tac std_ss [bc_ref_inv_def] + \\ fs [FLOOKUP_DEF,ThunkBlock_def] + \\ rw [] \\ simp [LENGTH]) + \\ fs [] \\ fs [get_real_offset_thm] + \\ Cases_on `l` \\ gvs [] + \\ fs [GSYM ThunkBlock_def] + \\ imp_res_tac heap_lookup_SPLIT \\ fs [] \\ clean_tac + \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND] + \\ fs [heap_store_ThunkBlock_thm,LENGTH_LUPDATE] \\ clean_tac + \\ fs [heap_length_APPEND] + \\ fs [heap_length_def,el_length_def,ThunkBlock_def] + \\ fs [word_heap_APPEND,word_heap_def,word_el_def,word_payload_def] + \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR,SEP_CLAUSES] + \\ fs [word_list_def,SEP_CLAUSES] + \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND,LUPDATE_LENGTH] + \\ fs [word_list_def,word_list_APPEND,SEP_CLAUSES,heap_length_def] + \\ fs [el_length_def,SUM_APPEND] + \\ fs [GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] + \\ SEP_R_TAC \\ fs [] + \\ SEP_W_TAC \\ fs [AC STAR_ASSOC STAR_COMM] + \\ cheat +QED + Definition store_list_def: (store_list a [] (m:'a word -> 'a word_loc) dm = SOME m) /\ (store_list a (w::ws) m dm = From 7709976e10827e6b911d298176044ecbebf98c8f Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Mon, 11 Aug 2025 12:52:45 +0300 Subject: [PATCH 036/112] `UpdateThunk` done in `data_to_word` --- .../proofs/data_to_word_assignProofScript.sml | 5 +- .../proofs/data_to_word_memoryProofScript.sml | 245 +++++++++--------- 2 files changed, 130 insertions(+), 120 deletions(-) diff --git a/compiler/backend/proofs/data_to_word_assignProofScript.sml b/compiler/backend/proofs/data_to_word_assignProofScript.sml index 90e998c67a..db396b9c2b 100644 --- a/compiler/backend/proofs/data_to_word_assignProofScript.sml +++ b/compiler/backend/proofs/data_to_word_assignProofScript.sml @@ -5069,7 +5069,7 @@ Proof \\ drule0 reorder_2_lemma \\ strip_tac \\ reverse $ Cases_on `ev` \\ gvs [] >- ( - drule0 (memory_rel_UpdateThunk |> GEN_ALL) \\ fs [] + drule0 (memory_rel_UpdateThunk_NotEvaluated |> GEN_ALL) \\ fs [] \\ strip_tac \\ clean_tac \\ `word_exp t (real_addr c (adjust_var h)) = SOME (Word x')` by metis_tac [get_real_offset_lemma,get_real_addr_lemma] @@ -5089,8 +5089,7 @@ Proof dimword_def, memory_rel_def, heap_in_memory_store_def, consume_space_def, arch_size_def] \\ rfs[NOT_LESS]) - \\ drule0 (memory_rel_UpdateThunk' |> GEN_ALL) \\ fs [] - \\ disch_then drule + \\ drule0 (memory_rel_UpdateThunk_Evaluated |> GEN_ALL) \\ fs [] \\ strip_tac \\ clean_tac \\ `word_exp t (real_addr c (adjust_var h)) = SOME (Word x'')` by metis_tac [get_real_offset_lemma,get_real_addr_lemma] diff --git a/compiler/backend/proofs/data_to_word_memoryProofScript.sml b/compiler/backend/proofs/data_to_word_memoryProofScript.sml index c8e4614632..e2b3ba8eef 100644 --- a/compiler/backend/proofs/data_to_word_memoryProofScript.sml +++ b/compiler/backend/proofs/data_to_word_memoryProofScript.sml @@ -3187,14 +3187,14 @@ QED Triviality heap_store_ThunkBlock: (heap_lookup n heap = SOME (ThunkBlock NotEvaluated y)) ⇒ ∃heap2. - heap_store n [ThunkBlock NotEvaluated h] heap = (heap2,T) ∧ + heap_store n [ThunkBlock ev h] heap = (heap2,T) ∧ ThunkBlock_inv heap heap2 ∧ - (heap_lookup n heap2 = SOME (ThunkBlock NotEvaluated h)) ∧ + (heap_lookup n heap2 = SOME (ThunkBlock ev h)) ∧ (heap_length heap2 = heap_length heap) ∧ (FILTER isForwardPointer heap2 = FILTER isForwardPointer heap) ∧ (∀xs l d. MEM (DataElement xs l d) heap2 ⇒ - (DataElement xs l d = ThunkBlock NotEvaluated h) ∨ + (DataElement xs l d = ThunkBlock ev h) ∨ MEM (DataElement xs l d) heap) ∧ (∀a. isSomeDataElement (heap_lookup a heap2) = isSomeDataElement (heap_lookup a heap)) ∧ @@ -3342,7 +3342,7 @@ val data_up_to_alt = prove( \\ rw [] \\ eq_tac \\ rw []); val update_thunk_gen_state_ok = prove( - ``heap_store b [ThunkBlock NotEvaluated t1] heap = (heap2,T) ∧ a <= b ∧ + ``heap_store b [ThunkBlock ev t1] heap = (heap2,T) ∧ a <= b ∧ gen_state_ok a (a + (sp + sp1)) heap gens ⇒ gen_state_ok a (a + (sp + sp1)) heap2 gens``, Cases_on `gens` \\ fs [gen_state_ok_def] @@ -3702,9 +3702,9 @@ Theorem update_thunk_thm: ?p r roots2 v1 heap2 u. (roots = r :: Pointer p u :: roots2) ∧ (thunk_deref p heap = SOME v1) ∧ - (heap_store p [ThunkBlock NotEvaluated r] heap = (heap2,T)) ∧ + (heap_store p [ThunkBlock ev r] heap = (heap2,T)) ∧ abs_ml_inv conf (h::(RefPtr b ptr)::stack) - (insert ptr (Thunk NotEvaluated h) refs) + (insert ptr (Thunk ev h) refs) (roots,heap2,be,a,sp,sp1,gens) limit ts Proof simp_tac std_ss [abs_ml_inv_def] @@ -3723,7 +3723,7 @@ Proof \\ `thunk_deref (f ' ptr) heap = SOME [z]` by ( fs[thunk_deref_def,ThunkBlock_def,FLOOKUP_DEF] ) \\ imp_res_tac heap_store_ThunkBlock - \\ POP_ASSUM (MP_TAC o Q.SPEC `x`) + \\ pop_assum $ qspecl_then [`x`, `ev`] mp_tac \\ full_simp_tac std_ss [] \\ simp[LENGTH_LUPDATE] \\ strip_tac \\ full_simp_tac std_ss [] \\ full_simp_tac (srw_ss()) [FLOOKUP_DEF] @@ -3759,14 +3759,14 @@ Proof \\ qpat_x_assum `heap_length h1 = _` (assume_tac o GSYM) \\ fs[] \\ SIMP_TAC std_ss [GSYM APPEND_ASSOC,gen_gc_partialTheory.heap_split_length] - \\ fs[isRef_def,ThunkBlock_def]) + \\ fs[isRef_def,ThunkBlock_def,isMutTag_def]) \\ strip_tac THEN1 (full_simp_tac std_ss [unused_space_inv_def] \\ rpt strip_tac \\ res_tac \\ Cases_on `a = f ' ptr` \\ full_simp_tac (srw_ss()) [] THEN1 full_simp_tac (srw_ss()) [ThunkBlock_def] \\ imp_res_tac data_up_to_heap_store \\ fs []) \\ qexists_tac `f` \\ full_simp_tac std_ss [] - \\ qexists_tac `DRESTRICT tf (all_ts (insert ptr (Thunk NotEvaluated h) refs) + \\ qexists_tac `DRESTRICT tf (all_ts (insert ptr (Thunk ev h) refs) (h::RefPtr b ptr::stack))` \\ full_simp_tac std_ss [] \\ MP_TAC v_inv_Thunk @@ -6166,7 +6166,102 @@ Proof \\ SEP_W_TAC \\ fs [AC STAR_ASSOC STAR_COMM] QED -Theorem memory_rel_UpdateThunk: +Definition store_list_def: + (store_list a [] (m:'a word -> 'a word_loc) dm = SOME m) /\ + (store_list a (w::ws) m dm = + if a IN dm then + store_list (a + bytes_in_word) ws ((a =+ w) m) dm + else NONE) +End + +Theorem store_list_append: + ∀xs ys a dm m m1. + store_list a (xs ++ ys) m dm = SOME m1 ⇔ + ∃m0. store_list a xs m dm = SOME m0 ∧ + store_list (a + bytes_in_word * n2w (LENGTH xs)) ys m0 dm = SOME m1 +Proof + Induct \\ fs [store_list_def] + \\ fs [ADD1,word_add_n2w,bytes_in_word_def,word_mul_n2w,RIGHT_ADD_DISTRIB] + \\ fs [GSYM word_add_n2w,AC CONJ_COMM CONJ_ASSOC,PULL_EXISTS] +QED + +Triviality minus_lemma: + -1w * (bytes_in_word * w) = bytes_in_word * -w +Proof + fs [] +QED + +Theorem n2w_lsr_eq_0: + n DIV 2 ** k = 0 /\ n < dimword (:'a) ==> n2w n >>> k = 0w:'a word +Proof + rw [] \\ simp_tac std_ss [GSYM w2n_11,w2n_lsr] \\ fs [] +QED + +Triviality LESS_EXO_SUB: + n < 2 ** (k - m) ==> n < 2n ** k +Proof + rw [] \\ match_mp_tac LESS_LESS_EQ_TRANS + \\ asm_exists_tac \\ fs [] +QED + +Triviality LESS_EXO_SUB_ALT: + m <= k ==> n < 2 ** (k - m) ==> n * 2 ** m < 2n ** k +Proof + rw [] \\ match_mp_tac LESS_LESS_EQ_TRANS + \\ qexists_tac `2 ** (k - m) * 2 ** m` + \\ fs [GSYM EXP_ADD] +QED + +Triviality less_pow_dimindex_sub_imp: + n < 2 ** (dimindex (:'a) - k) ==> n < dimword (:'a) +Proof + fs [dimword_def] \\ metis_tac [LESS_EXO_SUB] +QED + +Theorem encode_header_NEQ_0: + encode_header c n k = SOME w ==> w <> 0w +Proof + fs [encode_header_def] \\ rw [] + \\ fs [make_header_def,LET_DEF] + \\ full_simp_tac (srw_ss()++wordsLib.WORD_BIT_EQ_ss) [] + \\ qexists_tac `0` \\ fs [] \\ EVAL_TAC +QED + +Triviality encode_header_IMP: + encode_header c tag len = SOME (hd:'a word) /\ + c.len_size + 5 < dimindex (:'a) /\ good_dimindex (:'a) ==> + len < 2 ** (dimindex (:'a) - 4) /\ + decode_length c hd = n2w len +Proof + fs [encode_header_def] \\ rw [make_header_def] \\ fs [decode_length_def] + \\ `3w >>> (dimindex (:α) − c.len_size) = 0w:'a word` by + (match_mp_tac n2w_lsr_eq_0 + \\ fs [good_dimindex_def,dimword_def] + \\ fs [DIV_EQ_X] + \\ match_mp_tac LESS_LESS_EQ_TRANS + \\ qexists_tac `2 ** 2` + \\ strip_tac \\ TRY (EVAL_TAC \\ NO_TAC) + \\ simp_tac std_ss [EXP_BASE_LE_IFF] \\ fs []) + \\ `n2w tag << 2 ⋙ (dimindex (:α) - c.len_size) = 0w:'a word` by + (fs [WORD_MUL_LSL,word_mul_n2w] + \\ match_mp_tac n2w_lsr_eq_0 + \\ rpt strip_tac \\ TRY (match_mp_tac LESS_DIV_EQ_ZERO) + \\ `2 ** (dimindex (:α) − c.len_size) = + 2n ** 2 * 2 ** (dimindex (:α) − (c.len_size + 2))` by + (full_simp_tac std_ss [GSYM EXP_ADD] \\ fs []) \\ fs [] + \\ `4 * tag = tag * 2 ** 2` by fs [] + \\ asm_rewrite_tac [dimword_def] + \\ match_mp_tac (MP_CANON LESS_EXO_SUB_ALT) + \\ full_simp_tac std_ss [SUB_PLUS |> ONCE_REWRITE_RULE [ADD_COMM]] + \\ imp_res_tac LESS_EXO_SUB \\ fs []) + \\ fs [] \\ match_mp_tac lsl_lsr + \\ imp_res_tac less_pow_dimindex_sub_imp \\ fs [] + \\ `dimword (:'a) = 2 ** c.len_size * 2 ** (dimindex (:α) − c.len_size)` + suffices_by fs [] + \\ fs [GSYM EXP_ADD,dimword_def] +QED + +Theorem memory_rel_UpdateThunk_NotEvaluated: memory_rel c be ts refs sp st m dm ((h,w)::(RefPtr bl nn,ptr)::vars) /\ lookup nn refs = SOME (Thunk NotEvaluated v) /\ @@ -6184,6 +6279,7 @@ Proof \\ fs [memory_rel_def,PULL_EXISTS] \\ rw [] \\ fs [word_ml_inv_def,PULL_EXISTS] \\ clean_tac \\ rpt_drule (update_thunk_thm |> GEN_ALL) + \\ disch_then $ qspec_then `NotEvaluated` mp_tac \\ fs [LENGTH_EQ_1,PULL_EXISTS] \\ rpt strip_tac \\ fs [] \\ clean_tac \\ rewrite_tac [GSYM CONJ_ASSOC] @@ -6224,11 +6320,17 @@ Proof \\ SEP_W_TAC \\ fs [AC STAR_ASSOC STAR_COMM] QED -Theorem memory_rel_UpdateThunk': +Triviality thunk_tag_bits_lemma: + (thunk_tag_to_bits Evaluated ≪ 3 ‖ 6w) = 14w:'a word +Proof + simp [thunk_tag_to_bits_def,WORD_MUL_LSL] +QED + +Theorem memory_rel_UpdateThunk_Evaluated: memory_rel c be ts refs sp st m dm ((h,w)::(RefPtr bl nn,ptr)::vars) /\ lookup nn refs = SOME (Thunk NotEvaluated v) /\ - encode_header c hx hy = SOME hdr /\ + encode_header c (8 + 6) 1 = SOME hdr /\ good_dimindex (:'a) ==> ?ptr_w x:'a word. ptr = Word ptr_w /\ @@ -6243,20 +6345,18 @@ Proof \\ fs [memory_rel_def,PULL_EXISTS] \\ rw [] \\ fs [word_ml_inv_def,PULL_EXISTS] \\ clean_tac \\ rpt_drule (update_thunk_thm |> GEN_ALL) + \\ disch_then $ qspec_then `Evaluated` mp_tac \\ simp [] \\ fs [LENGTH_EQ_1,PULL_EXISTS] \\ rpt strip_tac \\ fs [] \\ clean_tac \\ rewrite_tac [GSYM CONJ_ASSOC] \\ once_rewrite_tac [METIS_PROVE [] ``b1 /\ b2 /\ b3 <=> b2 /\ b1 /\ b3:bool``] - \\ `abs_ml_inv c (h::RefPtr bl nn::MAP FST vars) - (insert nn (Thunk Evaluated h) refs) - (v'::Pointer p u::xs',heap2,be,a,sp',sp1,gens) limit ts` by cheat - \\ pop_assum mp_tac \\ pop_assum kall_tac \\ strip_tac \\ asm_exists_tac \\ fs [word_addr_def] - \\ fs [thunk_deref_def] \\ every_case_tac \\ fs [] \\ clean_tac + \\ fs [thunk_deref_def, AllCaseEqs()] \\ fs [] \\ clean_tac \\ fs [heap_in_memory_store_def] \\ rpt_drule get_real_addr_get_addr \\ fs [] \\ disch_then kall_tac - \\ `LENGTH l = 1 ∧ n = 1` by + \\ rename1 `SOME (DataElement l1 n1 (ThunkTag NotEvaluated,[]))` + \\ `LENGTH l1 = 1 ∧ n1 = 1` by (qpat_x_assum `abs_ml_inv _ _ _ _ _ _` kall_tac \\ fs [abs_ml_inv_def,bc_stack_ref_inv_def,v_inv_def] \\ clean_tac @@ -6269,14 +6369,15 @@ Proof \\ fs [FLOOKUP_DEF,ThunkBlock_def] \\ rw [] \\ simp [LENGTH]) \\ fs [] \\ fs [get_real_offset_thm] - \\ Cases_on `l` \\ gvs [] + \\ Cases_on `l1` \\ gvs [] \\ fs [GSYM ThunkBlock_def] \\ imp_res_tac heap_lookup_SPLIT \\ fs [] \\ clean_tac \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND] \\ fs [heap_store_ThunkBlock_thm,LENGTH_LUPDATE] \\ clean_tac \\ fs [heap_length_APPEND] \\ fs [heap_length_def,el_length_def,ThunkBlock_def] - \\ fs [word_heap_APPEND,word_heap_def,word_el_def,word_payload_def] + \\ fs [word_heap_APPEND,word_heap_def,word_el_def,word_payload_def, + UPDATE_LIST_def] \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR,SEP_CLAUSES] \\ fs [word_list_def,SEP_CLAUSES] \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND,LUPDATE_LENGTH] @@ -6284,103 +6385,13 @@ Proof \\ fs [el_length_def,SUM_APPEND] \\ fs [GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB] \\ SEP_R_TAC \\ fs [] - \\ SEP_W_TAC \\ fs [AC STAR_ASSOC STAR_COMM] - \\ cheat -QED - -Definition store_list_def: - (store_list a [] (m:'a word -> 'a word_loc) dm = SOME m) /\ - (store_list a (w::ws) m dm = - if a IN dm then - store_list (a + bytes_in_word) ws ((a =+ w) m) dm - else NONE) -End - -Theorem store_list_append: - ∀xs ys a dm m m1. - store_list a (xs ++ ys) m dm = SOME m1 ⇔ - ∃m0. store_list a xs m dm = SOME m0 ∧ - store_list (a + bytes_in_word * n2w (LENGTH xs)) ys m0 dm = SOME m1 -Proof - Induct \\ fs [store_list_def] - \\ fs [ADD1,word_add_n2w,bytes_in_word_def,word_mul_n2w,RIGHT_ADD_DISTRIB] - \\ fs [GSYM word_add_n2w,AC CONJ_COMM CONJ_ASSOC,PULL_EXISTS] -QED - -Triviality minus_lemma: - -1w * (bytes_in_word * w) = bytes_in_word * -w -Proof - fs [] -QED - -Theorem n2w_lsr_eq_0: - n DIV 2 ** k = 0 /\ n < dimword (:'a) ==> n2w n >>> k = 0w:'a word -Proof - rw [] \\ simp_tac std_ss [GSYM w2n_11,w2n_lsr] \\ fs [] -QED - -Triviality LESS_EXO_SUB: - n < 2 ** (k - m) ==> n < 2n ** k -Proof - rw [] \\ match_mp_tac LESS_LESS_EQ_TRANS - \\ asm_exists_tac \\ fs [] -QED - -Triviality LESS_EXO_SUB_ALT: - m <= k ==> n < 2 ** (k - m) ==> n * 2 ** m < 2n ** k -Proof - rw [] \\ match_mp_tac LESS_LESS_EQ_TRANS - \\ qexists_tac `2 ** (k - m) * 2 ** m` - \\ fs [GSYM EXP_ADD] -QED - -Triviality less_pow_dimindex_sub_imp: - n < 2 ** (dimindex (:'a) - k) ==> n < dimword (:'a) -Proof - fs [dimword_def] \\ metis_tac [LESS_EXO_SUB] -QED - -Theorem encode_header_NEQ_0: - encode_header c n k = SOME w ==> w <> 0w -Proof - fs [encode_header_def] \\ rw [] - \\ fs [make_header_def,LET_DEF] - \\ full_simp_tac (srw_ss()++wordsLib.WORD_BIT_EQ_ss) [] - \\ qexists_tac `0` \\ fs [] \\ EVAL_TAC -QED - -Triviality encode_header_IMP: - encode_header c tag len = SOME (hd:'a word) /\ - c.len_size + 5 < dimindex (:'a) /\ good_dimindex (:'a) ==> - len < 2 ** (dimindex (:'a) - 4) /\ - decode_length c hd = n2w len -Proof - fs [encode_header_def] \\ rw [make_header_def] \\ fs [decode_length_def] - \\ `3w >>> (dimindex (:α) − c.len_size) = 0w:'a word` by - (match_mp_tac n2w_lsr_eq_0 - \\ fs [good_dimindex_def,dimword_def] - \\ fs [DIV_EQ_X] - \\ match_mp_tac LESS_LESS_EQ_TRANS - \\ qexists_tac `2 ** 2` - \\ strip_tac \\ TRY (EVAL_TAC \\ NO_TAC) - \\ simp_tac std_ss [EXP_BASE_LE_IFF] \\ fs []) - \\ `n2w tag << 2 ⋙ (dimindex (:α) - c.len_size) = 0w:'a word` by - (fs [WORD_MUL_LSL,word_mul_n2w] - \\ match_mp_tac n2w_lsr_eq_0 - \\ rpt strip_tac \\ TRY (match_mp_tac LESS_DIV_EQ_ZERO) - \\ `2 ** (dimindex (:α) − c.len_size) = - 2n ** 2 * 2 ** (dimindex (:α) − (c.len_size + 2))` by - (full_simp_tac std_ss [GSYM EXP_ADD] \\ fs []) \\ fs [] - \\ `4 * tag = tag * 2 ** 2` by fs [] - \\ asm_rewrite_tac [dimword_def] - \\ match_mp_tac (MP_CANON LESS_EXO_SUB_ALT) - \\ full_simp_tac std_ss [SUB_PLUS |> ONCE_REWRITE_RULE [ADD_COMM]] - \\ imp_res_tac LESS_EXO_SUB \\ fs []) - \\ fs [] \\ match_mp_tac lsl_lsr - \\ imp_res_tac less_pow_dimindex_sub_imp \\ fs [] - \\ `dimword (:'a) = 2 ** c.len_size * 2 ** (dimindex (:α) − c.len_size)` - suffices_by fs [] - \\ fs [GSYM EXP_ADD,dimword_def] + \\ conj_tac + >- ( + drule encode_header_IMP \\ gvs [] + \\ strip_tac + \\ gvs [encode_header_def,thunk_tag_bits_lemma]) + \\ SEP_W_TAC + \\ fs [encode_header_def,AC STAR_ASSOC STAR_COMM,thunk_tag_bits_lemma] QED Theorem word_list_exists_thm: From 69c5455d157f6ba07a8aea9135b193fdce612d1e Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Mon, 11 Aug 2025 18:22:02 +0200 Subject: [PATCH 037/112] Sketch wordLang implemtnation of ForceThunk --- compiler/backend/data_to_wordScript.sml | 45 +++++++++++++++++++++++++ 1 file changed, 45 insertions(+) diff --git a/compiler/backend/data_to_wordScript.sml b/compiler/backend/data_to_wordScript.sml index 666688af4e..765b0720fc 100644 --- a/compiler/backend/data_to_wordScript.sml +++ b/compiler/backend/data_to_wordScript.sml @@ -1236,6 +1236,50 @@ val def = assign_Define ` Assign (adjust_var dest) Unit],l))) : 'a wordLang$prog # num`; +val def = assign_Define ` + assign_ForceThunk (c:data_to_word$config) secn (l:num) (dest:num) (names:num_set option) v1 = + let (s1,s2) = adjust_sets (get_names names) in + let cutsets = (s1, insert 9 () s2) in + (dtcase encode_header c (8 + 6) 1 of + | NONE => (GiveUp,l) + | SOME (header:'a word) => + If Test (adjust_var v1) (Imm 1w) + (Assign (adjust_var dest) (Var (adjust_var v1))) $ + (list_Seq + [Assign 1 (real_addr c (adjust_var v1)); + Assign 3 (Op And [Load (Var 1); Const 0b1111w]); + If Equal 3 (Imm (n2w (8 + 6))) + (Assign (adjust_var dest) + (Op And [Load (Op Add [Var 1; Const bytes_in_word])])) $ + If NotEqual 3 (Imm (n2w (0 + 6))) + (Assign (adjust_var dest) (Var (adjust_var v1))) + (* rest is the implementation of AppUnit + update thunk *) + (list_Seq + [(* pointer to closure value, i.e., var 0 in AppUnit *) + Assign 5 (Load (Op Add [Var 1; Const bytes_in_word])); + (* AppUnit's ElemAt 1 *) + Assign 15 (real_addr c 5); + Assign 7 (Load (Op Add [Var 15; Const (bytes_in_word * 2w)])); + Assign 9 (Var (adjust_var v1)); + Assign 13 (Const 2w); (* Cons 0 *) + (* AppUnit's EqualConst and If *) + If Equal 7 (Imm 0w) + (list_Seq + [Assign 11 (Load (Op Add [Var 15; Const bytes_in_word])); + Call (SOME ([9],cutsets,Skip,secn,l)) + NONE [13; 5; 11] NONE]) + (list_Seq + [Call (SOME ([9],cutsets,Skip,secn,l+1)) + (SOME bvl_num_stubs) [13; 5] NONE]); + (* update the thunk header to Evaluated and set payload *) + Assign 1 (real_addr c 9); + Assign 3 (Const header); + Store (Var 1) 3; + Store (Op Add [Var 1; Const bytes_in_word]) 19; + Assign (adjust_var dest) (Var 19); + ])]),l+2) + : 'a wordLang$prog # num`; + val def = assign_Define ` assign_UpdateByte (c:data_to_word$config) (l:num) (dest:num) v1 v2 v3 = (list_Seq [ @@ -2374,6 +2418,7 @@ Definition assign_def: | MemOp Ref => assign_Ref c secn l dest names args | ThunkOp (AllocThunk ev) => arg1 args (assign_AllocThunk ev c secn l dest names) (Skip,l) | ThunkOp (UpdateThunk ev) => arg2 args (assign_UpdateThunk ev c l dest) (Skip,l) + | ThunkOp ForceThunk => arg1 args (assign_ForceThunk c secn l dest names) (Skip,l) | MemOp (RefByte imm) => arg2 args (assign_RefByte c secn l dest names imm) (Skip,l) | MemOp XorByte => arg2 args (assign_XorByte c secn l dest names) (Skip,l) | Label n => (LocValue (adjust_var dest) n,l) From 56e0c94b924d26eea56230931e26be7258dcc3bc Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Tue, 12 Aug 2025 16:29:42 +0800 Subject: [PATCH 038/112] Add Force to top-level of bvl$exp --- compiler/backend/bvlScript.sml | 2 + compiler/backend/semantics/bvlSemScript.sml | 55 ++++++++++----------- 2 files changed, 29 insertions(+), 28 deletions(-) diff --git a/compiler/backend/bvlScript.sml b/compiler/backend/bvlScript.sml index eba4de98fe..1f115877d3 100644 --- a/compiler/backend/bvlScript.sml +++ b/compiler/backend/bvlScript.sml @@ -34,6 +34,8 @@ Datatype: | Handle exp exp | Tick exp | Call num (num option) (exp list) + | Force num (* loc to call for evaluation of unevaluated thunk *) + num (* var holding thunk *) | Op closLang$op (exp list) End diff --git a/compiler/backend/semantics/bvlSemScript.sml b/compiler/backend/semantics/bvlSemScript.sml index 1beadf2f71..f405a8b56f 100644 --- a/compiler/backend/semantics/bvlSemScript.sml +++ b/compiler/backend/semantics/bvlSemScript.sml @@ -504,15 +504,16 @@ Datatype: End Definition dest_thunk_def: - dest_thunk [RefPtr _ ptr] refs = + dest_thunk (RefPtr _ ptr) refs = (case FLOOKUP refs ptr of | NONE => BadRef | SOME (Thunk Evaluated v) => IsThunk Evaluated v | SOME (Thunk NotEvaluated v) => IsThunk NotEvaluated v | SOME _ => NotThunk) ∧ - dest_thunk vs refs = NotThunk + dest_thunk _ refs = NotThunk End +(* Definition store_thunk_def: store_thunk ptr v refs = case FLOOKUP refs ptr of @@ -528,12 +529,7 @@ Definition update_thunk_def: update_thunk _ _ _ = NONE End -Definition AppUnit_def: - AppUnit = - If (Op (BlockOp (EqualConst (Int 0))) [mk_elem_at (Var 0) 1]) - (Call 0 NONE [mk_unit; Var 0; mk_elem_at (Var 0) 0]) - (Call 0 (SOME 0) [mk_unit; Var 0]) -End +*) (* The evaluation is defined as a clocked functional version of a conventional big-step operational semantics. *) @@ -590,28 +586,31 @@ Definition evaluate_def: (evaluate ([Op op xs],env,s) = case fix_clock s (evaluate (xs,env,s)) of | (Rval vs,s) => - if op = ThunkOp ForceThunk then - (case dest_thunk vs s.refs of - | BadRef => (Rerr (Rabort Rtype_error),s) - | NotThunk => (Rerr (Rabort Rtype_error),s) - | IsThunk Evaluated v => (Rval [v],s) - | IsThunk NotEvaluated f => - if s.clock = 0 then - (Rerr (Rabort Rtimeout_error),s) - else - case evaluate ([AppUnit],[f],(dec_clock 1 s)) of - | (Rval vs2,s) => - (case update_thunk vs s.refs vs2 of - | NONE => (Rerr (Rabort Rtype_error),s) - | SOME refs => (Rval vs2,s with refs := refs)) - | (Rerr e,s) => (Rerr e,s)) - else - (case do_app op (REVERSE vs) s of - | Rerr err => (Rerr err,s) - | Rval (v,s) => (Rval [v],s)) + (case do_app op (REVERSE vs) s of + | Rerr err => (Rerr err,s) + | Rval (v,s) => (Rval [v],s)) | res => res) /\ (evaluate ([Tick x],env,s) = - if s.clock = 0 then (Rerr(Rabort Rtimeout_error),s) else evaluate ([x],env,dec_clock 1 s)) /\ + if s.clock = 0 then (Rerr(Rabort Rtimeout_error),s) + else evaluate ([x],env,dec_clock 1 s)) /\ + (evaluate ([Force force_loc n],env,s) = + if ~(n < LENGTH env) then (Rerr(Rabort Rtype_error),s) else + let thunk_v = EL n env in + case dest_thunk thunk_v s.refs of + | BadRef => (Rerr (Rabort Rtype_error),s) + | NotThunk => (Rerr (Rabort Rtype_error),s) + | IsThunk Evaluated v => (Rval [v],s) + | IsThunk NotEvaluated f => + if s.clock = 0 then + (Rerr (Rabort Rtimeout_error),s) + else + (case find_code (SOME force_loc) [thunk_v; f] s.code of + | NONE => (Rerr(Rabort Rtype_error),s) + | SOME (args,exp) => + if s.clock = 0 then + (Rerr(Rabort Rtimeout_error),s with clock := 0) + else + evaluate ([exp],args,dec_clock 1 s))) /\ (evaluate ([Call ticks dest xs],env,s1) = case fix_clock s1 (evaluate (xs,env,s1)) of | (Rval vs,s) => From 72f385acff12dbca9f084c71c0fc4a368971c2a3 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Tue, 12 Aug 2025 16:31:04 +0800 Subject: [PATCH 039/112] Compile closLang's ThunkOp ForceThunk to BVL's Force exp --- compiler/backend/backend_commonScript.sml | 2 +- compiler/backend/clos_to_bvlScript.sml | 27 ++++++++++++++++++----- 2 files changed, 23 insertions(+), 6 deletions(-) diff --git a/compiler/backend/backend_commonScript.sml b/compiler/backend/backend_commonScript.sml index 8d9c9ebdea..f9d787040c 100644 --- a/compiler/backend/backend_commonScript.sml +++ b/compiler/backend/backend_commonScript.sml @@ -129,7 +129,7 @@ Definition data_num_stubs_def: End Definition bvl_num_stubs_def: - bvl_num_stubs = data_num_stubs + 8 + (* dummy to make it a multiple of 3 *) 1 + bvl_num_stubs = data_num_stubs + 9 + (* dummy to make it a multiple of 3 *) 0 End Definition bvl_to_bvi_namespaces_def: diff --git a/compiler/backend/clos_to_bvlScript.sml b/compiler/backend/clos_to_bvlScript.sml index 1c7cde1cf1..da06ea04ae 100644 --- a/compiler/backend/clos_to_bvlScript.sml +++ b/compiler/backend/clos_to_bvlScript.sml @@ -273,6 +273,7 @@ Definition num_stubs_def: (* generic apps *) max_app (* partial apps *) + max_app * (max_app - 1) DIV 2 + 1 (* code to install a jump table in global 0 *) + + 1 (* location for force_thunk stub *) End Definition generic_app_fn_location_def: @@ -399,6 +400,16 @@ Definition init_globals_def: (Call 0 (SOME start_loc) [])) End +Definition force_thunk_code_def: + force_thunk_code = + If (Op (BlockOp (EqualConst (Int 0))) [mk_elem_at (Var 0) 1]) + (Let [Call 0 NONE [mk_unit; Var 0; mk_elem_at (Var 0) 0]] + (Let [Op (ThunkOp (UpdateThunk Evaluated)) [Var 0; Var 1]] (Var 1))) + (Let [Call 0 (SOME 0) [mk_unit; Var 0]] + (Let [Op (ThunkOp (UpdateThunk Evaluated)) [Var 0; Var 1]] (Var 1))) + : bvl$exp +End + Definition compile_exps_def: (compile_exps max_app [] aux = ([],aux)) /\ (compile_exps max_app ((x:closLang$exp)::y::xs) aux = @@ -425,6 +436,8 @@ Definition compile_exps_def: let (c1,aux1) = compile_exps max_app xs aux in ([if op = Install then Call 0 NONE [Op Install c1] + else if op = ThunkOp ForceThunk then + Let c1 (Force (num_stubs max_app - 2) 0) else Op (compile_op op) c1] ,aux1)) /\ @@ -512,6 +525,7 @@ Definition compile_exp_sing_def: (compile_exp_sing max_app (Op t op xs) aux = let (c1,aux1) = compile_exp_list max_app xs aux in (if op = Install then Call 0 NONE [Op Install c1] + else if op = ThunkOp ForceThunk then Let c1 (Force (num_stubs max_app - 2) 0) else Op (compile_op op) c1 ,aux1)) /\ (compile_exp_sing max_app (App t loc_opt x1 xs2) aux = @@ -860,8 +874,9 @@ Definition make_name_alist_def: make_name_alist nums prog nstubs dec_start (dec_length:num) = let src_names = get_src_names (MAP (SND o SND) prog) LN in fromAList(MAP(λn.(n, if n < nstubs then - if n = nstubs-1 then mlstring$strlit "bvl_init" - else mlstring$strlit "bvl_stub" + if n = nstubs-1 then mlstring$strlit "bvl_init" else + if n = nstubs-2 then mlstring$strlit "bvl_force" else + mlstring$strlit "bvl_stub" else let clos_name = n - nstubs in if dec_start ≤ clos_name ∧ clos_name < dec_start + dec_length then mlstring$strlit "dec" else @@ -877,13 +892,15 @@ Theorem make_name_alist_eq = Definition compile_def: compile c0 es = let (c, prog) = compile_common c0 es in + let n = num_stubs c.max_app in let init_stubs = toAList (init_code c.max_app) in - let init_globs = [(num_stubs c.max_app - 1, 0n, init_globals c.max_app (num_stubs c.max_app + c.start))] in + let init_globs = [(n - 1, 0n, init_globals c.max_app (n + c.start))] in + let force_stub = [(n - 1, 2n, force_thunk_code)] in let comp_progs = compile_prog c.max_app prog in let prog' = init_stubs ++ init_globs ++ comp_progs in - let func_names = make_name_alist (MAP FST prog') prog (num_stubs c.max_app) + let func_names = make_name_alist (MAP FST prog') prog n c0.next_loc (LENGTH es) in - let c = c with start := num_stubs c.max_app - 1 in + let c = c with start := n - 1 in (c, code_sort prog', func_names) End From eb43a60525bb65d7e82ab43220592ace58bb7fce Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Tue, 12 Aug 2025 16:31:35 +0800 Subject: [PATCH 040/112] Various adjustments for BVL's new Force --- compiler/backend/bvl_constScript.sml | 2 + compiler/backend/bvl_handleScript.sml | 8 ++++ compiler/backend/bvl_inlineScript.sml | 10 ++++ compiler/backend/semantics/bvlPropsScript.sml | 46 +++++++++++-------- 4 files changed, 47 insertions(+), 19 deletions(-) diff --git a/compiler/backend/bvl_constScript.sml b/compiler/backend/bvl_constScript.sml index 597169f825..c8689f6856 100644 --- a/compiler/backend/bvl_constScript.sml +++ b/compiler/backend/bvl_constScript.sml @@ -318,6 +318,7 @@ Definition compile_def: [Raise (HD (compile env [x1]))]) /\ (compile env [Op op xs] = [SmartOp op (compile env xs)]) /\ (compile env [Tick x] = [Tick (HD (compile env [x]))]) /\ + (compile env [Force loc v] = [Force loc v]) /\ (compile env [Call t dest xs] = [Call t dest (compile env xs)]) End @@ -345,6 +346,7 @@ Definition compile_sing_def: Raise (compile_sing env x1)) /\ (compile_sing env (Op op xs) = SmartOp op (compile_list env xs)) /\ (compile_sing env (Tick x) = Tick (compile_sing env x)) /\ + (compile_sing env (Force loc v) = Force loc v) ∧ (compile_sing env (Call t dest xs) = Call t dest (compile_list env xs)) ∧ (compile_list env [] = []) /\ diff --git a/compiler/backend/bvl_handleScript.sml b/compiler/backend/bvl_handleScript.sml index 8fc948bf83..0bfb78c913 100644 --- a/compiler/backend/bvl_handleScript.sml +++ b/compiler/backend/bvl_handleScript.sml @@ -17,6 +17,7 @@ Definition can_raise_def: (can_raise (Raise x1) = T) ∧ (can_raise (Op op xs) = (op = ThunkOp ForceThunk ∨ can_raise1 xs)) ∧ (can_raise (Tick x) = can_raise x) ∧ + (can_raise (Force m n) = T) ∧ (can_raise (Call t dest xs) = T) ∧ (can_raise1 [] = F) ∧ (can_raise1 (x::xs) = (can_raise x ∨ can_raise1 xs)) @@ -52,6 +53,7 @@ Definition handle_adj_vars_def: (handle_adj_vars l d (Raise x1) = Raise (handle_adj_vars l d x1)) ∧ (handle_adj_vars l d (Op op xs) = Op op (handle_adj_vars1 l d xs)) ∧ (handle_adj_vars l d (Tick x) = Tick (handle_adj_vars l d x)) ∧ + (handle_adj_vars l d (Force m v) = Force m (if v < l then v else v+d)) ∧ (handle_adj_vars l d (Call t dest xs) = Call t dest (handle_adj_vars1 l d xs)) ∧ (handle_adj_vars1 l d [] = []) ∧ @@ -66,6 +68,7 @@ Definition handle_size_def: (handle_size (Raise x1) = 1 + handle_size x1) ∧ (handle_size (Op op xs) = 1 + handle_size1 xs) ∧ (handle_size (Tick x) = 1 + handle_size x) ∧ + (handle_size (Force m n) = 1) ∧ (handle_size (Call t dest xs) = 1 + handle_size1 xs) ∧ (handle_size1 [] = 1:num) ∧ (handle_size1 (x::xs) = 1 + handle_size x + handle_size1 xs) @@ -85,6 +88,7 @@ Definition handle_simp_def: (handle_simp (Raise x1) = Raise (handle_simp x1)) /\ (handle_simp (Op op xs) = Op op (handle_simp_list xs)) /\ (handle_simp (Tick x) = Tick (handle_simp x)) /\ + (handle_simp (Force m n) = Force m n) /\ (handle_simp (Call t dest xs) = Call t dest (handle_simp_list xs)) /\ (handle_simp_list [] = ([]:bvl$exp list)) /\ (handle_simp_list (x::xs) = handle_simp x :: handle_simp_list xs) /\ @@ -198,6 +202,8 @@ Definition compile_def: (compile l n [Tick x] = let (y,lx,s1,nr1) = compile l n [x] in ([Tick (HD y)],lx,s1,nr1)) /\ + (compile l n [Force m v] = if v < n then ([Force m v],Var v,1,F) + else ([Op (IntOp (Const 0)) []],Empty,1,T)) /\ (compile l n [Call t dest xs] = let (ys,lx,s1,nr1) = compile l n xs in OptionalLetLet (Call t dest ys) n lx (s1+1) l F) @@ -244,6 +250,8 @@ Definition compile_sing_def: (compile_sing l n (Tick x) = let (y,lx,s1,nr1) = compile_sing l n x in (Tick y,lx,s1,nr1)) /\ + (compile_sing l n (Force m v) = if v < n then (Force m v,Var v,1,F) + else (Op (IntOp (Const 0)) [],Empty,1,T)) /\ (compile_sing l n (Call t dest xs) = let (ys,lx,s1,nr1) = compile_list l n xs in OptionalLetLet_sing (Call t dest ys) n lx (s1+1) l F) ∧ diff --git a/compiler/backend/bvl_inlineScript.sml b/compiler/backend/bvl_inlineScript.sml index 7c8c63bcc1..c8216da3c5 100644 --- a/compiler/backend/bvl_inlineScript.sml +++ b/compiler/backend/bvl_inlineScript.sml @@ -30,6 +30,7 @@ Definition tick_inline_def: [Op op (tick_inline cs xs)]) /\ (tick_inline cs [Tick x] = [Tick (HD (tick_inline cs [x]))]) /\ + (tick_inline cs [Force m n] = [Force m n]) /\ (tick_inline cs [Call ticks dest xs] = case dest of NONE => [Call ticks dest (tick_inline cs xs)] | SOME n => case lookup n cs of @@ -55,6 +56,7 @@ Definition tick_inline_sing_def: (Op op (tick_inline_list cs xs))) /\ (tick_inline_sing cs (Tick x) = (Tick (tick_inline_sing cs x))) /\ + (tick_inline_sing cs (Force m n) = Force m n) /\ (tick_inline_sing cs (Call ticks dest xs) = case dest of NONE => Call ticks dest (tick_inline_list cs xs) | SOME n => case lookup n cs of @@ -103,6 +105,7 @@ Definition is_small_aux_def: let n = n - 1 in if n = 0 then 0 else is_small_aux n xs) /\ (is_small_aux n [Tick x] = is_small_aux n [x]) /\ + (is_small_aux n [Force _ _] = n) /\ (is_small_aux n [Call ticks dest xs] = let n = n - 1 in if n = 0 then 0 else is_small_aux n xs) @@ -130,6 +133,7 @@ Definition is_small_sing_def: let n = n - 1 in if n = 0 then 0 else is_small_list n xs) /\ (is_small_sing n (Tick x) = is_small_sing n x) /\ + (is_small_sing n (Force _ _) = n) /\ (is_small_sing n (Call ticks dest xs) = let n = n - 1 in if n = 0 then 0 else is_small_list n xs) /\ @@ -176,6 +180,7 @@ Definition is_rec_def: is_rec n [x2]) /\ (is_rec n [Op op xs] = is_rec n xs) /\ (is_rec n [Tick x] = is_rec n [x]) /\ + (is_rec n [Force _ _] = F) /\ (is_rec n [Call ticks dest xs] = if dest = SOME n then T else is_rec n xs) End @@ -195,6 +200,7 @@ Definition is_rec_sing_def: is_rec_sing n x2) /\ (is_rec_sing n (Op op xs) = is_rec_list n xs) /\ (is_rec_sing n (Tick x) = is_rec_sing n x) /\ + (is_rec_sing n (Force _ _) = F) /\ (is_rec_sing n (Call ticks dest xs) = if dest = SOME n then T else is_rec_list n xs) /\ (is_rec_list n [] = F) /\ @@ -269,6 +275,7 @@ Definition remove_ticks_def: (remove_ticks [Op op xs] = [Op op (remove_ticks xs)]) /\ (remove_ticks [Tick x] = remove_ticks [x]) /\ + (remove_ticks [Force m n] = [Force m n]) /\ (remove_ticks [Call ticks dest xs] = [Call 0 dest (remove_ticks xs)]) End @@ -289,6 +296,7 @@ Definition remove_ticks_sing_def: (remove_ticks_sing (Op op xs) = Op op (remove_ticks_list xs)) /\ (remove_ticks_sing (Tick x) = remove_ticks_sing x) /\ + (remove_ticks_sing (Force m n) = Force m n) /\ (remove_ticks_sing (Call ticks dest xs) = Call 0 dest (remove_ticks_list xs)) /\ (remove_ticks_list [] = []) /\ @@ -354,6 +362,7 @@ Definition let_op_def: (let_op [Op op xs] = [Op op (let_op xs)]) /\ (let_op [Tick x] = [Tick (HD (let_op [x]))]) /\ + (let_op [Force m n] = [Force m n]) /\ (let_op [Call ticks dest xs] = [Call ticks dest (let_op xs)]) End @@ -377,6 +386,7 @@ Definition let_op_one_def: (let_op_one (Op op xs) = Op op (let_op_list xs)) /\ (let_op_one (Tick x) = Tick (let_op_one x)) /\ + (let_op_one (Force m n) = Force m n) /\ (let_op_one (Call ticks dest xs) = Call ticks dest (let_op_list xs)) /\ (let_op_list [] = []) /\ (let_op_list ((x:bvl$exp)::xs) = diff --git a/compiler/backend/semantics/bvlPropsScript.sml b/compiler/backend/semantics/bvlPropsScript.sml index 6df34e09f3..dc87447ff9 100644 --- a/compiler/backend/semantics/bvlPropsScript.sml +++ b/compiler/backend/semantics/bvlPropsScript.sml @@ -336,20 +336,28 @@ Proof \\ metis_tac []) THEN1 ( fs [case_eq_thms] \\ reverse $ rw [] \\ gvs [dec_clock_def] - \\ TRY (metis_tac []) - >- ( - Cases_on `op` \\ gvs [do_app_def, AllCaseEqs()] - >~ [`do_install`] >- ( - gvs [do_install_def, AllCaseEqs()] - \\ pairarg_tac \\ gvs [AllCaseEqs(), shift_seq_def] - \\ qmatch_goalsub_rename_tac `nn + _` - \\ qexists `nn + 1` \\ gvs [] - \\ once_rewrite_tac [ADD_COMM] - \\ gvs [GENLIST_APPEND] - \\ simp [GSYM SNOC_APPEND, FOLDL_SNOC]) - \\ rpt (pairarg_tac \\ gvs []) - \\ metis_tac []) - \\ gvs [AllCaseEqs()] + >- (metis_tac []) + >- (metis_tac []) + \\ Cases_on `op` \\ gvs [do_app_def, AllCaseEqs()] + >~ [`do_install`] >- + (gvs [do_install_def, AllCaseEqs()] + \\ pairarg_tac \\ gvs [AllCaseEqs(), shift_seq_def] + \\ qmatch_goalsub_rename_tac `nn + _` + \\ qexists `nn + 1` \\ gvs [] + \\ once_rewrite_tac [ADD_COMM] + \\ gvs [GENLIST_APPEND] + \\ simp [GSYM SNOC_APPEND, FOLDL_SNOC]) + \\ rpt (pairarg_tac \\ gvs []) + \\ metis_tac []) + THEN1 + (fs [case_eq_thms] \\ rw [] \\ fs [] + THEN1 (qexists_tac `0` \\ fs [shift_seq_def,FUN_EQ_THM]) + \\ pop_assum (assume_tac o GSYM) \\ fs [] + \\ qexists_tac `n` \\ fs [dec_clock_def]) + THEN1 + cheat (* + + gvs [AllCaseEqs()] \\ rw [] \\ fs [] >~ [`dest_thunk _ _ = BadRef`] >- (qexists `n` \\ gvs []) >~ [`dest_thunk _ _ = NotThunk`] >- (qexists `n` \\ gvs []) >~ [`dest_thunk _ _ = IsThunk Evaluated _`] >- (qexists `n` \\ gvs []) @@ -358,11 +366,8 @@ Proof \\ rewrite_tac [GENLIST_APPEND,FOLDL_APPEND,MAP_APPEND] \\ fs [dec_clock_def,shift_seq_def,FUN_EQ_THM] \\ simp_tac std_ss [Once ADD_COMM] \\ fs []) - THEN1 - (fs [case_eq_thms] \\ rw [] \\ fs [] - THEN1 (qexists_tac `0` \\ fs [shift_seq_def,FUN_EQ_THM]) - \\ pop_assum (assume_tac o GSYM) \\ fs [] - \\ qexists_tac `n` \\ fs [dec_clock_def]) + +*) \\ fs [case_eq_thms] \\ rw [] \\ fs [] \\ TRY (qexists_tac `n` \\ fs [] \\ NO_TAC) \\ pop_assum (assume_tac o GSYM) \\ fs [] @@ -821,6 +826,7 @@ Definition bVarBound_def[simp]: (bVarBound n [Raise x1] <=> bVarBound n [x1]) /\ (bVarBound n [Tick x1] <=> bVarBound n [x1]) /\ (bVarBound n [Op op xs] <=> bVarBound n xs) /\ + (bVarBound n [Force loc v] <=> v < n) /\ (bVarBound n [Handle x1 x2] <=> bVarBound n [x1] /\ bVarBound (n + 1) [x2]) /\ (bVarBound n [Call ticks dest xs] <=> bVarBound n xs) @@ -841,6 +847,7 @@ Definition bEvery_def[simp]: bEvery P xs /\ bEvery P [x2]) /\ (bEvery P [Raise x1] <=> P (Raise x1) /\ bEvery P [x1]) /\ (bEvery P [Tick x1] <=> P (Tick x1) /\ bEvery P [x1]) /\ + (bEvery P [Force m n] <=> P (Force m n)) /\ (bEvery P [Op op xs] <=> P (Op op xs) /\ bEvery P xs) /\ (bEvery P [Handle x1 x2] <=> P (Handle x1 x2) /\ bEvery P [x1] /\ bEvery P [x2]) /\ @@ -872,6 +879,7 @@ Definition get_code_labels_def: (get_code_labels (Raise e) = get_code_labels e) ∧ (get_code_labels (Handle e1 e2) = get_code_labels e1 ∪ get_code_labels e2) ∧ (get_code_labels (Tick e) = get_code_labels e) ∧ + (get_code_labels (Force loc v) = {loc}) ∧ (get_code_labels (Call _ d es) = (case d of NONE => {} | SOME n => {n}) ∪ BIGUNION (set (MAP get_code_labels es))) ∧ (get_code_labels (Op op es) = closLang$assign_get_code_label op ∪ BIGUNION (set (MAP get_code_labels es))) Termination From d82e43e570c20067affea8b23398e17aacd24c76 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Wed, 13 Aug 2025 00:23:37 +0800 Subject: [PATCH 041/112] Sketch new Force proof --- compiler/backend/clos_to_bvlScript.sml | 4 +- .../backend/proofs/clos_to_bvlProofScript.sml | 65 +++++++++++++++---- compiler/backend/semantics/bvlPropsScript.sml | 18 +++-- 3 files changed, 66 insertions(+), 21 deletions(-) diff --git a/compiler/backend/clos_to_bvlScript.sml b/compiler/backend/clos_to_bvlScript.sml index da06ea04ae..0d49e544c5 100644 --- a/compiler/backend/clos_to_bvlScript.sml +++ b/compiler/backend/clos_to_bvlScript.sml @@ -895,9 +895,9 @@ Definition compile_def: let n = num_stubs c.max_app in let init_stubs = toAList (init_code c.max_app) in let init_globs = [(n - 1, 0n, init_globals c.max_app (n + c.start))] in - let force_stub = [(n - 1, 2n, force_thunk_code)] in + let force_stub = [(n - 2, 2n, force_thunk_code)] in let comp_progs = compile_prog c.max_app prog in - let prog' = init_stubs ++ init_globs ++ comp_progs in + let prog' = init_stubs ++ force_stub ++ init_globs ++ comp_progs in let func_names = make_name_alist (MAP FST prog') prog n c0.next_loc (LENGTH es) in let c = c with start := n - 1 in diff --git a/compiler/backend/proofs/clos_to_bvlProofScript.sml b/compiler/backend/proofs/clos_to_bvlProofScript.sml index 89694db594..2f3c42af9a 100644 --- a/compiler/backend/proofs/clos_to_bvlProofScript.sml +++ b/compiler/backend/proofs/clos_to_bvlProofScript.sml @@ -1137,6 +1137,7 @@ Definition state_rel_def: lookup (generic_app_fn_location n) t.code = SOME (n + 2, generate_generic_app s.max_app n)) ∧ (!tot n. tot < s.max_app ∧ n < tot ⇒ lookup (partial_app_fn_location s.max_app tot n) t.code = SOME (tot - n + 1, generate_partial_app_closure_fn tot n)) ∧ + lookup (num_stubs s.max_app - 2) t.code = SOME (2,force_thunk_code) ∧ compile_oracle_inv s.max_app s.code s.compile s.compile_oracle t.code t.compile t.compile_oracle ∧ (!name arity c. @@ -3399,20 +3400,20 @@ QED Theorem rel_dest_thunk: state_rel f s t ∧ - LIST_REL (v_rel s.max_app f t.refs t.code) vs ys ∧ - dest_thunk vs s.refs = IsThunk m r1 ⇒ - ∃r2. dest_thunk ys t.refs = IsThunk m r2 ∧ + v_rel s.max_app f t.refs t.code h y ∧ + dest_thunk [h] s.refs = IsThunk m r1 ⇒ + ∃r2. + dest_thunk y t.refs = IsThunk m r2 ∧ v_rel s.max_app f t.refs t.code r1 r2 Proof rw [] \\ gvs [oneline closSemTheory.dest_thunk_def, oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] - \\ ( - qpat_x_assum `v_rel _ _ _ _ (RefPtr _ _) y` mp_tac - \\ reverse $ rw [Once v_rel_cases] - >- gvs [add_args_F] - >- rgs [Once cl_rel_cases] - \\ drule_all state_rel_refs_lookup \\ rw [] \\ gvs []) + \\ (qpat_x_assum `v_rel _ _ _ _ (RefPtr _ _) y` mp_tac + \\ reverse $ rw [Once v_rel_cases] + >- gvs [add_args_F] + >- rgs [Once cl_rel_cases] + \\ drule_all state_rel_refs_lookup \\ rw [] \\ gvs []) QED Theorem compile_exps_correct: @@ -3991,8 +3992,41 @@ Proof ) \\ srw_tac[][] \\ Cases_on `op = ThunkOp ForceThunk` >- ( - gvs [closSemTheory.evaluate_def, compile_exps_def] + ‘lookup (num_stubs s.max_app − 2) t1.code = + SOME (2,force_thunk_code)’ by fs [state_rel_def] + \\ last_x_assum assume_tac + \\ gvs [closSemTheory.evaluate_def, compile_exps_def] \\ pairarg_tac \\ gvs [evaluate_def] + \\ Cases_on ‘evaluate (xs,env,s)’ \\ fs [] + \\ Cases_on ‘q = Rerr (Rabort Rtype_error)’ \\ fs [] + \\ first_x_assum drule_all + \\ strip_tac + \\ reverse $ Cases_on ‘q’ \\ gvs [] + >- + (qexists_tac ‘ck’ \\ fs [] + \\ first_x_assum $ irule_at $ Pos hd \\ fs []) + \\ Cases_on ‘dest_thunk a r.refs’ \\ fs [] + \\ rename [‘IsThunk thunk_mode’] + \\ qrefine ‘ck + ck2’ \\ gvs [] + \\ drule evaluate_add_clock \\ simp [inc_clock_def] + \\ disch_then kall_tac + \\ ‘LENGTH a = 1’ by gvs [oneline closSemTheory.dest_thunk_def,AllCaseEqs()] + \\ gvs [LENGTH_EQ_NUM_compute] + \\ drule_at (Pos last) rel_dest_thunk + \\ imp_res_tac evaluate_const \\ gvs [] + \\ disch_then drule_all + \\ strip_tac \\ fs [] + \\ Cases_on ‘thunk_mode’ \\ fs [] + >- (gvs [] \\ first_x_assum $ irule_at $ Pos hd \\ fs []) + \\ simp [bvlSemTheory.find_code_def] + \\ Cases_on ‘t2.clock = 0’ \\ fs [] + >- + (qexists_tac ‘0’ \\ gvs [] + \\ first_x_assum $ irule_at $ Pos hd \\ fs []) + \\ drule bvlPropsTheory.evaluate_mono + \\ simp [subspt_lookup] + \\ disch_then drule \\ strip_tac \\ simp [dec_clock_def] + \\ cheat (* \\ gvs [AllCaseEqs(), PULL_EXISTS] >- ( first_x_assum drule_all \\ rw [] \\ gvs [] @@ -4117,7 +4151,7 @@ Proof >- ( first_x_assum drule_all \\ rw [] \\ gvs [] \\ goal_assum drule \\ rw [PULL_EXISTS] - \\ goal_assum drule \\ gvs [])) + \\ goal_assum drule \\ gvs []) *) ) \\ srw_tac[][] \\ full_simp_tac(srw_ss())[cEval_def,compile_exps_def] \\ SRW_TAC [] [bEval_def] \\ `?p. evaluate (xs,env,s) = p` by full_simp_tac(srw_ss())[] \\ PairCases_on `p` \\ full_simp_tac(srw_ss())[] @@ -7690,6 +7724,7 @@ Theorem compile_prog_semantics: FEVERY (λp. every_Fn_SOME [SND (SND p)]) code1 ∧ FEVERY (λp. every_Fn_vs_SOME [SND (SND p)]) code1 ∧ lookup nsm1 code2 = SOME (0, init_globals max_app (num_stubs max_app + start)) /\ + lookup (num_stubs max_app - 2) code2 = SOME (2,force_thunk_code) ∧ compile_oracle_inv max_app code1 cc1 co1 code2 cc2 co2 ∧ code_installed prog2 code2 ⇒ @@ -8486,7 +8521,8 @@ Theorem syntax_oracle_ok_to_oracle_inv: (pure_cc (compile_inc c.max_app) cc) co' (fromAList (toAList (init_code c.max_app) ++ - [(num_stubs c.max_app - 1,0, + [(num_stubs c.max_app − 2,2,force_thunk_code); + (num_stubs c.max_app - 1,0, init_globals c.max_app (c''.start + num_stubs c.max_app))] ++ compile_prog c.max_app prog')) cc (pure_co (compile_inc c.max_app) ∘ co') @@ -8949,6 +8985,7 @@ Proof \\ imp_res_tac ALOOKUP_MEM \\ metis_tac[] ) \\ conj_tac >- ( irule ALOOKUP_ALL_DISTINCT_MEM \\ fs[] ) + \\ conj_tac >- ( irule ALOOKUP_ALL_DISTINCT_MEM \\ fs[] ) \\ simp[Once CONJ_ASSOC] \\ conj_tac >- ( fs[compile_common_def] @@ -9109,7 +9146,7 @@ Theorem compile_exps_code_labels: ⊆ IMAGE (((+) (num_stubs app))) (BIGUNION (set (MAP get_code_labels es1))) ∪ BIGUNION (set (MAP (get_code_labels o SND o SND) aux1)) ∪ - domain (init_code app) + domain (init_code app) ∪ {num_stubs app − 2} Proof recInduct clos_to_bvlTheory.compile_exps_ind \\ rw [clos_to_bvlTheory.compile_exps_def] \\ rw [] @@ -9206,7 +9243,7 @@ Theorem compile_prog_code_labels: BIGUNION (set (MAP (get_code_labels o SND o SND) (compile_prog max_app prog))) SUBSET IMAGE (((+) (clos_to_bvl$num_stubs max_app))) (BIGUNION (set (MAP get_code_labels (MAP (SND o SND) prog)))) ∪ - domain (init_code max_app) + domain (init_code max_app) ∪ {num_stubs max_app − 2} Proof rw[clos_to_bvlTheory.compile_prog_def] \\ pairarg_tac \\ fs[] diff --git a/compiler/backend/semantics/bvlPropsScript.sml b/compiler/backend/semantics/bvlPropsScript.sml index dc87447ff9..0ad96d11cd 100644 --- a/compiler/backend/semantics/bvlPropsScript.sml +++ b/compiler/backend/semantics/bvlPropsScript.sml @@ -418,7 +418,7 @@ Proof EVAL_TAC QED -fun split_tac q = Cases_on q \\ Cases_on `q` \\ FULL_SIMP_TAC (srw_ss()) [] +fun split_tac q = Cases_on q \\ Cases_on `q` \\ FULL_SIMP_TAC (srw_ss()) []; Theorem evaluate_expand_env: !xs a s env. @@ -436,6 +436,10 @@ Proof THEN1 (split_tac `evaluate ([x1],env,s1)` \\ BasicProvers.CASE_TAC >> simp[]) THEN1 (split_tac `evaluate (xs,env,s)`) THEN1 (SRW_TAC [] []) + THEN1 + (rw [] \\ every_case_tac \\ gvs [oneline dest_thunk_def,AllCaseEqs()] + \\ Cases_on `n < LENGTH env` + \\ gvs [rich_listTheory.EL_APPEND1]) THEN1 (split_tac `evaluate (xs,env,s1)`) QED @@ -529,6 +533,7 @@ Theorem evaluate_add_clock: ⇒ !ck. evaluate (exps,env,inc_clock ck s1) = (res, inc_clock ck s2) Proof + cheat (* recInduct evaluate_ind >> srw_tac[][evaluate_def] >- (Cases_on `evaluate ([x], env,s)` >> full_simp_tac(srw_ss())[] >> @@ -571,7 +576,7 @@ Proof srw_tac[][] >- decide_tac >> `r.clock + ck - (ticks + 1) = r.clock - (ticks + 1) + ck` by srw_tac [ARITH_ss] [ADD1] >> - metis_tac []) + metis_tac []) *) QED Theorem evaluate_add_clock_initial_state: @@ -602,11 +607,12 @@ Theorem evaluate_io_events_mono: ⇒ s1.ffi.io_events ≼ s2.ffi.io_events Proof + cheat (* recInduct evaluate_ind >> srw_tac[][evaluate_def] >> every_case_tac >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> rev_full_simp_tac(srw_ss())[] >> - metis_tac[IS_PREFIX_TRANS,do_app_io_events_mono] + metis_tac[IS_PREFIX_TRANS,do_app_io_events_mono] *) QED Triviality do_app_inc_clock: @@ -642,6 +648,7 @@ Theorem evaluate_add_to_clock_io_events_mono: (SND(evaluate(exps,env,s))).ffi.io_events ≼ (SND(evaluate(exps,env,inc_clock extra s))).ffi.io_events Proof + cheat (* recInduct evaluate_ind >> srw_tac[][evaluate_def] >> TRY ( @@ -659,7 +666,7 @@ Proof full_simp_tac(srw_ss())[dec_clock_inc_clock] >> TRY (rename1 `dest_thunk _ _ = _` >> gvs [dec_clock_def, inc_clock_def]) >> metis_tac[evaluate_io_events_mono,SND,IS_PREFIX_TRANS,Boolv_11,PAIR, - inc_clock_ffi,dec_clock_ffi] + inc_clock_ffi,dec_clock_ffi] *) QED Triviality take_drop_lem: @@ -768,13 +775,14 @@ QED Triviality evaluate_refs_SUBSET_lemma: !xs env s. FDOM s.refs SUBSET FDOM (SND (evaluate (xs,env,s))).refs Proof + cheat (* recInduct evaluate_ind \\ REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[evaluate_def] \\ BasicProvers.EVERY_CASE_TAC \\ full_simp_tac(srw_ss())[] \\ REV_FULL_SIMP_TAC std_ss [] \\ IMP_RES_TAC SUBSET_TRANS \\ gvs [oneline update_thunk_def, AllCaseEqs(), store_thunk_def] \\ full_simp_tac(srw_ss())[dec_clock_def] \\ full_simp_tac(srw_ss())[] - \\ IMP_RES_TAC do_app_refs_SUBSET \\ full_simp_tac(srw_ss())[SUBSET_DEF] + \\ IMP_RES_TAC do_app_refs_SUBSET \\ full_simp_tac(srw_ss())[SUBSET_DEF] *) QED Theorem evaluate_refs_SUBSET: From 28655d14d1038390e8cb52ff18231235f485b89a Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Wed, 13 Aug 2025 03:04:57 +0200 Subject: [PATCH 042/112] Define Force in BVI and DataLang --- compiler/backend/bviScript.sml | 2 + compiler/backend/bvi_to_dataScript.sml | 11 ++- compiler/backend/dataLangScript.sml | 2 +- compiler/backend/data_to_wordScript.sml | 82 +++++++++---------- .../proofs/data_to_wordProofScript.sml | 5 +- .../proofs/data_to_word_assignProofScript.sml | 2 +- compiler/backend/semantics/bviSemScript.sml | 64 +++++---------- 7 files changed, 75 insertions(+), 93 deletions(-) diff --git a/compiler/backend/bviScript.sml b/compiler/backend/bviScript.sml index 2d56399a2e..d3e63548fa 100644 --- a/compiler/backend/bviScript.sml +++ b/compiler/backend/bviScript.sml @@ -45,6 +45,8 @@ Datatype: | Raise exp | Tick exp | Call num (num option) (exp list) (exp option) + | Force num (* loc to call for evaluation of unevaluated thunk *) + num (* var holding thunk *) | Op op (exp list) End diff --git a/compiler/backend/bvi_to_dataScript.sml b/compiler/backend/bvi_to_dataScript.sml index 4b3f362274..33bc410274 100644 --- a/compiler/backend/bvi_to_dataScript.sml +++ b/compiler/backend/bvi_to_dataScript.sml @@ -33,7 +33,6 @@ Theorem op_space_reset_pmatch: | MemOp (CopyByte new_flag) => new_flag | MemOp ConfigGC => T | FFI _ => T - | ThunkOp ForceThunk => T | _ => F Proof rpt strip_tac @@ -121,6 +120,11 @@ Definition compile_def: (compile n env tail live [Tick x1] = let (c1,v1,n1) = compile n env tail live [x1] in (Seq Tick c1, v1, n1)) /\ + (compile n env tail live [Force loc v] = + let var = any_el v env 0n in + let ret = (if tail then NONE + else SOME (n, list_to_num_set (live ++ env))) in + (Force ret loc var, [n], MAX (n+1) (var+1))) ∧ (compile n env tail live [Call ticks dest xs NONE] = let (c1,vs,n1) = compile n env F live xs in let ret = (if tail then NONE @@ -163,6 +167,11 @@ Definition compile_sing_def: (compile_sing n env tail live (Tick x1) = let (c1,v1,n1) = compile_sing n env tail live x1 in (Seq Tick c1, v1, n1)) /\ + (compile_sing n env tail live (Force loc v) = + let var = any_el v env 0n in + let ret = (if tail then NONE + else SOME (n, list_to_num_set (live ++ env))) in + (Force ret loc var, n, MAX (n+1) (var+1))) ∧ (compile_sing n env tail live (Call ticks dest xs NONE) = let (c1,vs,n1) = compile_list n env live xs in let ret = (if tail then NONE diff --git a/compiler/backend/dataLangScript.sml b/compiler/backend/dataLangScript.sml index 38b7e35340..a819fe7ae7 100644 --- a/compiler/backend/dataLangScript.sml +++ b/compiler/backend/dataLangScript.sml @@ -50,7 +50,6 @@ Definition op_space_reset_def: (op_space_reset (MemOp (CopyByte new_flag)) = new_flag) /\ (op_space_reset (MemOp ConfigGC) = T) /\ (op_space_reset (FFI _) = T) /\ - (op_space_reset (ThunkOp ForceThunk) = T) /\ (op_space_reset _ = F) End @@ -75,6 +74,7 @@ Datatype: | Raise num | Return num | Tick + | Force ((num # num_set) option) num num End Definition mk_ticks_def: diff --git a/compiler/backend/data_to_wordScript.sml b/compiler/backend/data_to_wordScript.sml index 765b0720fc..e45777aef4 100644 --- a/compiler/backend/data_to_wordScript.sml +++ b/compiler/backend/data_to_wordScript.sml @@ -1236,50 +1236,6 @@ val def = assign_Define ` Assign (adjust_var dest) Unit],l))) : 'a wordLang$prog # num`; -val def = assign_Define ` - assign_ForceThunk (c:data_to_word$config) secn (l:num) (dest:num) (names:num_set option) v1 = - let (s1,s2) = adjust_sets (get_names names) in - let cutsets = (s1, insert 9 () s2) in - (dtcase encode_header c (8 + 6) 1 of - | NONE => (GiveUp,l) - | SOME (header:'a word) => - If Test (adjust_var v1) (Imm 1w) - (Assign (adjust_var dest) (Var (adjust_var v1))) $ - (list_Seq - [Assign 1 (real_addr c (adjust_var v1)); - Assign 3 (Op And [Load (Var 1); Const 0b1111w]); - If Equal 3 (Imm (n2w (8 + 6))) - (Assign (adjust_var dest) - (Op And [Load (Op Add [Var 1; Const bytes_in_word])])) $ - If NotEqual 3 (Imm (n2w (0 + 6))) - (Assign (adjust_var dest) (Var (adjust_var v1))) - (* rest is the implementation of AppUnit + update thunk *) - (list_Seq - [(* pointer to closure value, i.e., var 0 in AppUnit *) - Assign 5 (Load (Op Add [Var 1; Const bytes_in_word])); - (* AppUnit's ElemAt 1 *) - Assign 15 (real_addr c 5); - Assign 7 (Load (Op Add [Var 15; Const (bytes_in_word * 2w)])); - Assign 9 (Var (adjust_var v1)); - Assign 13 (Const 2w); (* Cons 0 *) - (* AppUnit's EqualConst and If *) - If Equal 7 (Imm 0w) - (list_Seq - [Assign 11 (Load (Op Add [Var 15; Const bytes_in_word])); - Call (SOME ([9],cutsets,Skip,secn,l)) - NONE [13; 5; 11] NONE]) - (list_Seq - [Call (SOME ([9],cutsets,Skip,secn,l+1)) - (SOME bvl_num_stubs) [13; 5] NONE]); - (* update the thunk header to Evaluated and set payload *) - Assign 1 (real_addr c 9); - Assign 3 (Const header); - Store (Var 1) 3; - Store (Op Add [Var 1; Const bytes_in_word]) 19; - Assign (adjust_var dest) (Var 19); - ])]),l+2) - : 'a wordLang$prog # num`; - val def = assign_Define ` assign_UpdateByte (c:data_to_word$config) (l:num) (dest:num) v1 v2 v3 = (list_Seq [ @@ -2418,7 +2374,6 @@ Definition assign_def: | MemOp Ref => assign_Ref c secn l dest names args | ThunkOp (AllocThunk ev) => arg1 args (assign_AllocThunk ev c secn l dest names) (Skip,l) | ThunkOp (UpdateThunk ev) => arg2 args (assign_UpdateThunk ev c l dest) (Skip,l) - | ThunkOp ForceThunk => arg1 args (assign_ForceThunk c secn l dest names) (Skip,l) | MemOp (RefByte imm) => arg2 args (assign_RefByte c secn l dest names imm) (Skip,l) | MemOp XorByte => arg2 args (assign_XorByte c secn l dest names) (Skip,l) | Label n => (LocValue (adjust_var dest) n,l) @@ -2464,6 +2419,42 @@ Definition assign_def: | _ => (Skip,l) End +Definition force_thunk_def: + force_thunk (c:data_to_word$config) secn (l:num) ret loc v1 = + (dtcase encode_header c (8 + 6) 1 of + | NONE => (GiveUp,l) + | SOME (header:'a word) => + If Test (adjust_var v1) (Imm 1w) + (dtcase ret of + | NONE => Return 0 [adjust_var v1] + | SOME (dest,_) => Assign (adjust_var dest) (Var (adjust_var v1))) + (list_Seq + [Assign 1 (real_addr c (adjust_var v1)); + Assign 3 (Op And [Load (Var 1); Const 0b1111w]); + If Equal 3 (Imm (n2w (8 + 6))) + (dtcase ret of + | NONE => + list_Seq + [Assign 1 (Op And [Load (Op Add [Var 1; Const bytes_in_word])]); + Return 0 [1]] + | SOME (dest,_) => + Assign (adjust_var dest) + (Op And [Load (Op Add [Var 1; Const bytes_in_word])])) $ + If NotEqual 3 (Imm (n2w (0 + 6))) + (dtcase ret of + | NONE => Return 0 [adjust_var v1] + | SOME (dest,_) => Assign (adjust_var dest) (Var (adjust_var v1))) + (* rest is the implementation of AppUnit + update thunk *) + ARB (* + (list_Seq + [Assign 5 (Op And [Load (Op Add [Var 1; Const bytes_in_word])]); + Call (dtcase ret of + | NONE => NONE + | SOME (r,ns) => ([r],adjust_sets ns,Skip,secn,l)) + (SOME loc) [adjust_ar v1; 5] NONE])*)]),l+1) + : 'a wordLang$prog # num +End + Definition comp_def: comp c (secn:num) (l:num) (p:dataLang$prog) = dtcase p of @@ -2492,6 +2483,7 @@ Definition comp_def: SilentFFI c 3 (adjust_sets names)]) Skip),l) | Assign dest op args names => assign c secn l dest op args names + | Force ret loc v => force_thunk c secn l ret loc v | Call ret target args handler => dtcase ret of | NONE => (Call NONE target (0::MAP adjust_var args) NONE,l) diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml index d9128ae0b0..13c4f5f6a5 100644 --- a/compiler/backend/proofs/data_to_wordProofScript.sml +++ b/compiler/backend/proofs/data_to_wordProofScript.sml @@ -102,9 +102,7 @@ Proof \\ imp_res_tac word_ml_inv_get_var_IMP \\ match_mp_tac word_ml_inv_insert \\ fs []) >~ [‘evaluate (Assign _ _ _ _,s)’] >- - (Cases_on ‘op = ThunkOp ForceThunk’ - >- cheat - \\ full_simp_tac std_ss [] + (full_simp_tac std_ss [] \\ fs [comp_def,dataSemTheory.evaluate_def,wordSemTheory.evaluate_def] \\ imp_res_tac (METIS_PROVE [] ``(if b1 /\ b2 then x1 else x2) = y ==> b1 /\ b2 /\ x1 = y \/ @@ -133,6 +131,7 @@ Proof \\ Cases_on `names_opt` \\ fs [cut_state_opt_def] \\ srw_tac[][] \\ fs [] \\ fs [cut_state_def,cut_env_def] \\ every_case_tac \\ fs [] \\ rw [] \\ fs [set_var_def]) + >~ [‘evaluate (Force _ _ _,s)’] >- cheat >~ [‘evaluate (Tick,s)’] >- (fs [comp_def,dataSemTheory.evaluate_def,wordSemTheory.evaluate_def] \\ `t.clock = s.clock` by fs [state_rel_def] \\ fs [] \\ srw_tac[][] diff --git a/compiler/backend/proofs/data_to_word_assignProofScript.sml b/compiler/backend/proofs/data_to_word_assignProofScript.sml index fe40a05480..c85f92fd5e 100644 --- a/compiler/backend/proofs/data_to_word_assignProofScript.sml +++ b/compiler/backend/proofs/data_to_word_assignProofScript.sml @@ -14229,7 +14229,7 @@ Proof[exclude_simps = EXP_LE_LOG_SIMP EXP_LT_LOG_SIMP LE_EXP_LOG_SIMP QED Theorem assign_thm: - op ≠ ThunkOp ForceThunk ⇒ ^assign_thm_goal + ^assign_thm_goal Proof strip_tac \\ Cases_on `op = GlobOp AllocGlobal` \\ fs [] diff --git a/compiler/backend/semantics/bviSemScript.sml b/compiler/backend/semantics/bviSemScript.sml index a2620fe1f6..02f67d0a57 100644 --- a/compiler/backend/semantics/bviSemScript.sml +++ b/compiler/backend/semantics/bviSemScript.sml @@ -169,7 +169,7 @@ Datatype: End Definition dest_thunk_def: - dest_thunk [RefPtr _ ptr] refs = + dest_thunk (RefPtr _ ptr) refs = (case FLOOKUP refs ptr of | NONE => BadRef | SOME (Thunk Evaluated v) => IsThunk Evaluated v @@ -178,28 +178,6 @@ Definition dest_thunk_def: dest_thunk vs refs = NotThunk End -Definition store_thunk_def: - store_thunk ptr v refs = - case FLOOKUP refs ptr of - | SOME (Thunk NotEvaluated _) => SOME (refs |+ (ptr,v)) - | _ => NONE -End - -Definition update_thunk_def: - update_thunk [RefPtr _ ptr] refs [v] = - (case dest_thunk [v] refs of - | NotThunk => store_thunk ptr (Thunk Evaluated v) refs - | _ => NONE) ∧ - update_thunk _ _ _ = NONE -End - -Definition AppUnit_def: - AppUnit = - If (Op (BlockOp (EqualConst (Int 0))) [mk_elem_at (Var 0) 1]) - (Call 0 NONE [mk_unit; Var 0; mk_elem_at (Var 0) 0] NONE) - (Call 0 (SOME num_stubs) [mk_unit; Var 0] NONE) -End - (* The evaluation is defined as a clocked functional version of a conventional big-step operational semantics. *) @@ -247,29 +225,31 @@ Definition evaluate_def: (evaluate ([Op op xs],env,s) = case fix_clock s (evaluate (xs,env,s)) of | (Rval vs,s) => - if op = ThunkOp ForceThunk then - (case dest_thunk vs s.refs of - | BadRef => (Rerr (Rabort Rtype_error),s) - | NotThunk => (Rerr (Rabort Rtype_error),s) - | IsThunk Evaluated v => (Rval [v],s) - | IsThunk NotEvaluated f => - if s.clock = 0 then - (Rerr (Rabort Rtimeout_error),s) - else - case evaluate ([AppUnit],[f],(dec_clock 1 s)) of - | (Rval vs2,s) => - (case update_thunk vs s.refs vs2 of - | NONE => (Rerr (Rabort Rtype_error),s) - | SOME refs => (Rval vs2,s with refs := refs)) - | (Rerr e,s) => (Rerr e,s)) - else - (case do_app op (REVERSE vs) s of - | Rerr e => (Rerr e,s) - | Rval (v,s) => (Rval [v],s)) + (case do_app op (REVERSE vs) s of + | Rerr e => (Rerr e,s) + | Rval (v,s) => (Rval [v],s)) | res => res) /\ (evaluate ([Tick x],env,s) = if s.clock = 0 then (Rerr(Rabort Rtimeout_error),s) else evaluate ([x],env,dec_clock 1 s)) /\ + (evaluate ([Force force_loc n],env,s) = + if ~(n < LENGTH env) then (Rerr(Rabort Rtype_error),s) else + let thunk_v = EL n env in + case dest_thunk thunk_v s.refs of + | BadRef => (Rerr (Rabort Rtype_error),s) + | NotThunk => (Rerr (Rabort Rtype_error),s) + | IsThunk Evaluated v => (Rval [v],s) + | IsThunk NotEvaluated f => + if s.clock = 0 then + (Rerr (Rabort Rtimeout_error),s) + else + (case find_code (SOME force_loc) [thunk_v; f] s.code of + | NONE => (Rerr(Rabort Rtype_error),s) + | SOME (args,exp) => + if s.clock = 0 then + (Rerr(Rabort Rtimeout_error),s with clock := 0) + else + evaluate ([exp],args,dec_clock 1 s))) /\ (evaluate ([Call ticks dest xs handler],env,s1) = if IS_NONE dest /\ IS_SOME handler then (Rerr(Rabort Rtype_error),s1) else case fix_clock s1 (evaluate (xs,env,s1)) of From 28b645b5d9ba00df82629ea3da4ff5855eb0d846 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Wed, 13 Aug 2025 08:37:46 +0200 Subject: [PATCH 043/112] Get backend to build --- compiler/backend/backend_passesScript.sml | 4 +++- compiler/backend/bvi_letScript.sml | 2 ++ compiler/backend/bvi_tailrecScript.sml | 27 ++++++++++++++--------- compiler/backend/bvl_to_bviScript.sml | 5 +++++ 4 files changed, 27 insertions(+), 11 deletions(-) diff --git a/compiler/backend/backend_passesScript.sml b/compiler/backend/backend_passesScript.sml index 7ecc6ef9f4..32606a5209 100644 --- a/compiler/backend/backend_passesScript.sml +++ b/compiler/backend/backend_passesScript.sml @@ -85,7 +85,8 @@ Definition to_bvl_all_def: call_state := (g,aux)|> in let init_stubs = toAList (init_code c1.max_app) in let init_globs = - [(num_stubs c1.max_app − 1,0, + [(num_stubs c1.max_app − 2, 2, force_thunk_code); + (num_stubs c1.max_app − 1, 0, init_globals c1.max_app (num_stubs c1.max_app + c1.start))] in let comp_progs = clos_to_bvl$compile_prog c1.max_app prog in let prog' = init_stubs ++ init_globs ++ comp_progs in @@ -106,6 +107,7 @@ Proof \\ fs [to_bvl_all_def,to_bvl_def,clos_to_bvlTheory.compile_def, clos_to_bvlTheory.compile_common_def] \\ rpt (pairarg_tac \\ gvs []) + \\ rewrite_tac [GSYM APPEND_ASSOC,APPEND] QED Definition to_bvi_all_def: diff --git a/compiler/backend/bvi_letScript.sml b/compiler/backend/bvi_letScript.sml index 7ceebd8956..040287c967 100644 --- a/compiler/backend/bvi_letScript.sml +++ b/compiler/backend/bvi_letScript.sml @@ -90,6 +90,7 @@ Definition compile_def: [Raise (HD (compile env d [x1]))]) /\ (compile env d [Op op xs] = [Op op (compile env d xs)]) /\ (compile env d [Tick x] = [Tick (HD (compile env d [x]))]) /\ + (compile env d [Force loc v] = [Force loc v]) /\ (compile env d [Call t dest xs h] = [Call t dest (compile env d xs) (case h of NONE => NONE @@ -127,6 +128,7 @@ Definition compile_sing_def: (Raise ((compile_sing env d x1)))) /\ (compile_sing env d (Op op xs) = (Op op (compile_list env d xs))) /\ (compile_sing env d (Tick x) = (Tick (compile_sing env d x))) /\ + (compile_sing env d (Force loc v) = (Force loc v)) /\ (compile_sing env d (Call t dest xs h) = (Call t dest (compile_list env d xs) (case h of NONE => NONE diff --git a/compiler/backend/bvi_tailrecScript.sml b/compiler/backend/bvi_tailrecScript.sml index 7f3a0c0908..e533e34181 100644 --- a/compiler/backend/bvi_tailrecScript.sml +++ b/compiler/backend/bvi_tailrecScript.sml @@ -510,6 +510,9 @@ Definition scan_expr_def: [(DROP (LENGTH ys) tu, ty, F, op)]) ∧ (scan_expr ts loc [Raise x] = [(ts, Any, F, NONE)]) ∧ (scan_expr ts loc [Tick x] = scan_expr ts loc [x]) ∧ + (scan_expr ts loc [Force _ n] = + let ty = if n < LENGTH ts then EL n ts else Any in + [(ts, ty, F, NONE)]) ∧ (scan_expr ts loc [Call t d xs h] = [(ts, Any, F, NONE)]) ∧ (scan_expr ts loc [Op op xs] = let opr = from_op op in @@ -565,6 +568,9 @@ Definition scan_expr_sing_def: (DROP (LENGTH ys) tu, ty, F, op)) ∧ (scan_expr_sing ts loc (Raise x) = (ts, Any, F, NONE)) ∧ (scan_expr_sing ts loc (Tick x) = scan_expr_sing ts loc x) ∧ + (scan_expr_sing ts loc (Force _ n) = + let ty = if n < LENGTH ts then EL n ts else Any in + (ts, ty, F, NONE)) ∧ (scan_expr_sing ts loc (Call t d xs h) = (ts, Any, F, NONE)) ∧ (scan_expr_sing ts loc (Op op xs) = let opr = from_op op in @@ -638,6 +644,7 @@ Definition rewrite_def: (rewrite loc next opr acc ts (Tick x) = let (r, y) = rewrite loc next opr acc ts x in (r, Tick y)) /\ + (rewrite loc next opr acc ts (Force l v) = (F, Force l v)) /\ (rewrite loc next opr acc ts exp = dtcase check_op ts opr loc exp of NONE => (F, apply_op opr (Var acc) exp) @@ -667,6 +674,7 @@ Theorem rewrite_PMATCH: (r, Let xs y) | Tick x => let (r, y) = rewrite loc next opr acc ts x in (r, Tick y) + | Force l v => (F, Force l v) | _ => dtcase check_op ts opr loc expr of NONE => (F, apply_op opr (Var acc) expr) @@ -679,7 +687,6 @@ Proof \\ recInduct (theorem "rewrite_ind") \\ rw [rewrite_def] QED - Theorem rewrite_eq = rewrite_def |> SRULE [scan_expr_eq]; @@ -856,16 +863,16 @@ val opt_tm = `` NONE)))`` val aux_tm = ``Let [Var 0; Op (IntOp (Const 1)) []] ^opt_tm`` -Theorem fac_check_exp: +Triviality fac_check_exp: check_exp 0 1 ^fac_tm = SOME Times Proof -EVAL_TAC + EVAL_TAC QED Theorem fac_compile_exp: compile_exp 0 1 1 ^fac_tm = SOME (^aux_tm, ^opt_tm) Proof -EVAL_TAC + EVAL_TAC QED val rev_tm = `` @@ -891,16 +898,16 @@ val opt_tm = `` val aux_tm = ``Let [Var 0; Op (BlockOp (Cons 0)) []] ^opt_tm`` -Theorem rev_check_exp: - check_exp 444 1 ^rev_tm = SOME Append +Triviality rev_check_exp: + check_exp 444 1 ^rev_tm = SOME Append Proof -EVAL_TAC + EVAL_TAC QED -Theorem rev_compile_exp: - compile_exp 444 445 1 ^rev_tm = SOME (^aux_tm, ^opt_tm) +Triviality rev_compile_exp: + compile_exp 444 445 1 ^rev_tm = SOME (^aux_tm, ^opt_tm) Proof -EVAL_TAC + EVAL_TAC QED val _ = export_theory(); diff --git a/compiler/backend/bvl_to_bviScript.sml b/compiler/backend/bvl_to_bviScript.sml index 0d9308698c..2e03d04683 100644 --- a/compiler/backend/bvl_to_bviScript.sml +++ b/compiler/backend/bvl_to_bviScript.sml @@ -58,6 +58,7 @@ Definition alloc_glob_count_def: alloc_glob_count [x] + alloc_glob_count [y]) /\ (alloc_glob_count [Tick x] = alloc_glob_count [x]) /\ + (alloc_glob_count [Force loc v] = 0) /\ (alloc_glob_count [Raise x] = alloc_glob_count [x]) /\ (alloc_glob_count [Let xs x] = alloc_glob_count (x::xs)) /\ (alloc_glob_count [Call _ _ xs] = alloc_glob_count xs) /\ @@ -76,6 +77,7 @@ Definition global_count_sing_def: (global_count_sing (Handle x y) = global_count_sing x + global_count_sing y) /\ + (global_count_sing (Force loc v) = 0) /\ (global_count_sing (Tick x) = global_count_sing x) /\ (global_count_sing (Raise x) = global_count_sing x) /\ (global_count_sing (Let xs x) = @@ -356,6 +358,7 @@ Definition compile_exps_def: (compile_exps n [Tick x1] = let (c1,aux1,n1) = compile_exps n [x1] in ([Tick (HD c1)], aux1, n1)) /\ + (compile_exps n [Force loc v] = ([Force loc v], Nil, n)) /\ (compile_exps n [Op op xs] = let (c1,aux1,n1) = compile_exps n xs in ([compile_op op c1],aux1,n1)) /\ @@ -407,6 +410,8 @@ Definition compile_exps_sing_def: (compile_exps_sing n (Tick x1) = let (c1,aux1,n1) = compile_exps_sing n x1 in (Tick c1, aux1, n1)) /\ + (compile_exps_sing n (Force loc v) = + (Force loc v, Nil, n)) /\ (compile_exps_sing n (Op op xs) = let (c1,aux1,n1) = compile_exps_list n xs in (compile_op op c1,aux1,n1)) /\ From eab3054b8a5a9d311880bb7e29540ed0595192a5 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Wed, 13 Aug 2025 15:32:35 +0300 Subject: [PATCH 044/112] Prove various cheats outside `compiler/backend` --- candle/prover/permsScript.sml | 89 ++++++++- compiler/repl/evaluate_skipScript.sml | 278 +++++++++++++++++++++----- semantics/proofs/fpSemPropsScript.sml | 28 ++- 3 files changed, 336 insertions(+), 59 deletions(-) diff --git a/candle/prover/permsScript.sml b/candle/prover/permsScript.sml index d66f3a7534..89bf330386 100644 --- a/candle/prover/permsScript.sml +++ b/candle/prover/permsScript.sml @@ -38,7 +38,9 @@ Definition perms_ok_exp_def: (op = AallocFixed ⇒ RefAlloc ∈ ps) ∧ (op = Aw8alloc ⇒ W8Alloc ∈ ps) ∧ (op = Opassign ⇒ RefUpdate ∈ ps) ∧ - (∀chn. op = FFI chn ⇒ FFIWrite chn ∈ ps ∧ DoFFI ∈ ps) + (∀chn. op = FFI chn ⇒ FFIWrite chn ∈ ps ∧ DoFFI ∈ ps) ∧ + (∀m. op = ThunkOp (AllocThunk m) ⇒ RefAlloc ∈ ps) ∧ + (∀m. op = ThunkOp (UpdateThunk m) ⇒ RefUpdate ∈ ps) | _ => T End @@ -195,7 +197,8 @@ QED Definition perms_ok_ref_def: perms_ok_ref ps (Refv v) = perms_ok ps v ∧ perms_ok_ref ps (Varray vs) = EVERY (perms_ok ps) vs ∧ - perms_ok_ref ps (W8array ws) = T + perms_ok_ref ps (W8array ws) = T ∧ + perms_ok_ref ps (Thunk _ v) = perms_ok ps v End Definition perms_ok_state_def: @@ -308,6 +311,8 @@ Theorem do_app_perms: (op = Aw8alloc ⇒ W8Alloc ∈ ps) ∧ (op = Opassign ⇒ RefUpdate ∈ ps) ∧ (∀chn. op = FFI chn ⇒ FFIWrite chn ∈ ps ∧ DoFFI ∈ ps) ∧ + (∀m. op = ThunkOp (AllocThunk m) ⇒ RefAlloc ∈ ps) ∧ + (∀m. op = ThunkOp (UpdateThunk m) ⇒ RefUpdate ∈ ps) ∧ op ≠ Opapp ⇒ (∀n. n < LENGTH refs1 ∧ RefMention n ∈ ps ⇒ perms_ok_ref ps (EL n refs1)) ∧ (RefAlloc ∉ ps ∧ W8Alloc ∉ ps ⇒ LENGTH refs1 = LENGTH refs) ∧ @@ -320,7 +325,6 @@ Theorem do_app_perms: | Rerr (Rraise v) => perms_ok ps v | Rerr (Rabort err) => T Proof - cheat (* strip_tac \\ qpat_x_assum ‘do_app _ _ _ = _’ mp_tac \\ Cases_on ‘op = Env_id’ \\ gs [] @@ -587,7 +591,22 @@ Proof >- ( rw [do_app_cases] \\ gs[] \\ rw [perms_ok_def]) - \\ Cases_on ‘op’ \\ gs [] *) + \\ Cases_on ‘∃m. op = ThunkOp (AllocThunk m)’ \\ gs[] + >- ( + rw [do_app_cases] \\ gs [thunk_op_def, AllCaseEqs()] \\ pairarg_tac \\ gs [] + \\ gvs [perms_ok_def, store_alloc_def, perms_ok_ref_def, SUBSET_DEF] + \\ simp [EL_APPEND_EQN] + \\ rw [] \\ gs [] + \\ gvs [NOT_LESS, LESS_OR_EQ, perms_ok_ref_def]) + \\ Cases_on ‘∃m. op = ThunkOp (UpdateThunk m)’ \\ gs[] + >- ( + rw [do_app_cases] \\ gs [thunk_op_def, AllCaseEqs()] + \\ gvs [perms_ok_def, store_assign_def] + \\ rw [EL_LUPDATE, perms_ok_ref_def]) + \\ Cases_on ‘op = ThunkOp ForceThunk’ \\ gs[] + >- (rw [do_app_cases] \\ gvs [thunk_op_def]) + \\ Cases_on ‘op’ \\ gs [] + \\ Cases_on ‘t’ \\ gs [] QED Theorem perms_ok_do_opapp: @@ -697,7 +716,6 @@ Theorem evaluate_perms_ok: | Rval env1 => perms_ok_env ps UNIV env1 | _ => T) Proof - cheat (* ho_match_mp_tac full_evaluate_ind \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac >~ [‘[]’] >- ( @@ -733,7 +751,63 @@ Proof >~ [‘Fun n e’] >- ( gvs [evaluate_def, perms_ok_env_def, perms_ok_def, SF SFY_ss]) >~ [‘App op xs’] >- ( - gvs [evaluate_def] + Cases_on ‘getOpClass op = Force’ \\ gvs [] + >- ( + gvs [AllCaseEqs()] \\ gvs [evaluate_def] \\ gvs [AllCaseEqs()] + \\ gvs [perms_ok_env_BIGUNION, MEM_MAP, PULL_EXISTS, EVERY_MEM] + >- ( + gvs [oneline dest_thunk_def, AllCaseEqs(), store_lookup_def, + perms_ok_state_def] + \\ last_x_assum drule \\ rw [] \\ gvs [perms_ok_def, perms_ok_ref_def]) + \\ ( + gvs [AppUnit_def, sing_env_def, perms_ok_env_def, dec_clock_def, + namespaceTheory.nsEmpty_def, namespaceTheory.nsBind_def] + \\ gvs [oneline dest_thunk_def, AllCaseEqs(), store_lookup_def] + \\ gvs [evaluate_def, do_con_check_def, build_conv_def, + namespaceTheory.nsLookup_def, AllCaseEqs()] + \\ gvs [do_opapp_cases] + >- ((* Closure *) + last_x_assum mp_tac + \\ reverse impl_tac + >- ( + rw [] \\ gs [] + \\ gvs [oneline update_thunk_def, AllCaseEqs(), store_assign_def, + perms_ok_state_def, EL_LUPDATE] \\ rw [] + \\ gvs [perms_ok_ref_def] + \\ first_x_assum (drule_then assume_tac) \\ gs []) + \\ gs [SF DNF_ss, perms_ok_env_def, perms_ok_def, find_recfun_ALOOKUP, + EVERY_MEM, MEM_MAP, PULL_EXISTS, perms_ok_state_def] + \\ rw [] \\ gs [] + \\ ( + first_x_assum (drule_then assume_tac) + \\ gvs [perms_ok_ref_def, perms_ok_def, perms_ok_env_def] + \\ first_x_assum irule \\ gvs [] + \\ metis_tac [])) + >- ((* Recclosure *) + last_x_assum mp_tac + \\ reverse impl_tac + >- ( + rw [] \\ gs [] + \\ gvs [oneline update_thunk_def, AllCaseEqs(), store_assign_def, + perms_ok_state_def, EL_LUPDATE] \\ rw [] + \\ gvs [perms_ok_ref_def] + \\ first_x_assum (drule_then assume_tac) \\ gs []) + \\ gs [SF DNF_ss, perms_ok_env_def, perms_ok_def, find_recfun_ALOOKUP, + EVERY_MEM, MEM_MAP, PULL_EXISTS, perms_ok_state_def] + \\ drule_then assume_tac ALOOKUP_MEM + \\ qmatch_asmsub_abbrev_tac ‘MEM yyy funs’ + \\ first_x_assum drule \\ simp_tac std_ss [Abbr ‘yyy’] + \\ rw [] \\ gs [nsLookup_nsAppend_some, nsLookup_alist_to_ns_some, + nsLookup_alist_to_ns_none] + >- ( + gvs [perms_ok_ref_def, perms_ok_def, perms_ok_env_def] + \\ first_x_assum irule \\ gvs [] + \\ gvs [PULL_EXISTS, MEM_MAP, EVERY_MAP] + \\ metis_tac []) + >- gvs [perms_ok_ref_def, perms_ok_def, EVERY_MAP, EVERY_EL, + MEM_EL]))) + \\ gvs [AllCaseEqs()] + \\ gvs [evaluate_def] \\ Cases_on ‘op = Opapp’ \\ gs [] >- ((* Opapp *) gvs [CaseEqs ["result", "prod", "bool", "option"], @@ -795,6 +869,7 @@ Proof \\ Cases_on ‘getOpClass op’ \\ gs[] >~ [‘EvalOp’] >- (Cases_on ‘op’ \\ gs[]) >~ [‘FunApp’] >- (Cases_on ‘op’ \\ gs[]) + >~ [‘Force’] >- (Cases_on ‘op’ \\ gs[]) >~ [‘Simple’] >- ( gvs [CaseEqs ["result", "prod", "bool", "option"]] \\ drule_then (qspec_then ‘ps’ mp_tac) do_app_perms @@ -985,7 +1060,7 @@ Proof gs [perms_ok_env_def, extend_dec_env_def, nsLookup_nsAppend_some] \\ rw [] \\ gs [SF SFY_ss]) \\ rw [] - \\ first_x_assum (drule_then assume_tac) \\ gs []) *) + \\ first_x_assum (drule_then assume_tac) \\ gs []) QED Theorem evaluate_perms_ok_exp = diff --git a/compiler/repl/evaluate_skipScript.sml b/compiler/repl/evaluate_skipScript.sml index e374e77ff1..5f15a45d20 100644 --- a/compiler/repl/evaluate_skipScript.sml +++ b/compiler/repl/evaluate_skipScript.sml @@ -105,10 +105,11 @@ Theorem env_rel_def = “env_rel fr ft fe env1 env2” |> SIMP_CONV std_ss [Once v_rel_cases]; Definition ref_rel_def: - ref_rel f (Refv v) (Refv w) = f v w ∧ - ref_rel f (Varray vs) (Varray ws) = LIST_REL f vs ws ∧ - ref_rel f (W8array a) (W8array b) = (a = b) ∧ - ref_rel f _ _ = F + ref_rel f (Refv v) (Refv w) = f v w ∧ + ref_rel f (Varray vs) (Varray ws) = LIST_REL f vs ws ∧ + ref_rel f (W8array a) (W8array b) = (a = b) ∧ + ref_rel f (Thunk m1 v1) (Thunk m2 v2) = ((m1 = m2) ∧ f v1 v2) ∧ + ref_rel f _ _ = F End Theorem ref_rel_mono: @@ -125,9 +126,8 @@ Theorem ref_rel_refl: (∀x. P x x) ⇒ ref_rel P x x Proof - cheat (* Cases_on ‘x’ \\ rw [ref_rel_def] - \\ Induct_on ‘l’ \\ gs [] *) + \\ Induct_on ‘l’ \\ gs [] QED Definition state_rel_def: @@ -649,44 +649,44 @@ Theorem state_rel_store_assign: state_rel l fr ft fe s t ∧ FLOOKUP fr n = SOME m ∧ ref_rel (v_rel fr ft fe) v w ⇒ - OPTREL (λr1 r2. - state_rel l fr ft fe - (s with <| refs := r1 |>) (t with refs := r2)) - (store_assign n v s.refs) - (store_assign m w t.refs) -Proof - cheat (* - rw [OPTREL_def, store_assign_def, state_rel_def] - \\ ‘n < LENGTH s.refs ∧ m < LENGTH t.refs’ - by (qpat_x_assum ‘INJ ($' fr) _ _’ mp_tac - \\ qpat_x_assum ‘FLOOKUP fr n = _’ mp_tac - \\ rw [INJ_DEF, flookup_thm] - \\ first_x_assum drule \\ gs []) - \\ gs [] - \\ first_assum (qspec_then ‘n’ mp_tac) - \\ IF_CASES_TAC \\ gs [] - \\ rw [] - \\ ‘store_v_same_type (EL n s.refs) (EL m t.refs)’ - by (rw [store_v_same_type_def] - \\ CASE_TAC \\ gs [] \\ CASE_TAC \\ gs [ref_rel_def]) - \\ ‘store_v_same_type v w’ - by (rw [store_v_same_type_def] - \\ CASE_TAC \\ gs [] \\ CASE_TAC \\ gs [ref_rel_def]) - \\ ‘store_v_same_type (EL n s.refs) v = store_v_same_type (EL m t.refs) w’ - by (rw [EQ_IMP_THM] \\ gs [store_v_same_type_def] - \\ Cases_on ‘EL n s.refs’ \\ Cases_on ‘EL m t.refs’ - \\ Cases_on ‘v’ \\ Cases_on ‘w’ \\ gs []) - \\ csimp [] - \\ simp [DISJ_EQ_IMP] - \\ strip_tac \\ gs [] - \\ qx_gen_tac ‘n1’ - \\ first_x_assum (qspec_then ‘n1’ assume_tac) - \\ rw [] \\ gs [EL_LUPDATE] - \\ rw [] \\ gs [ref_rel_def] - \\ qpat_x_assum ‘INJ ($' fr) _ _’ mp_tac - \\ qpat_x_assum ‘FLOOKUP fr n1 = SOME _’ mp_tac - \\ qpat_x_assum ‘FLOOKUP fr n = SOME _’ mp_tac - \\ rw [flookup_thm, INJ_DEF] \\ gs [] *) + OPTREL + (λr1 r2. state_rel l fr ft fe (s with refs := r1) (t with refs := r2)) + (store_assign n v s.refs) + (store_assign m w t.refs) +Proof + rw [OPTREL_def] \\ gvs [] + \\ ‘n < LENGTH s.refs ∧ m < LENGTH t.refs’ by ( + gvs [state_rel_def] + \\ qpat_x_assum ‘INJ ($' fr) _ _’ mp_tac + \\ qpat_x_assum ‘FLOOKUP fr n = _’ mp_tac + \\ rw [INJ_DEF, flookup_thm] + \\ first_x_assum drule \\ rw []) + \\ Cases_on ‘store_assign n v s.refs’ \\ gvs [] + >- ( + gvs [store_assign_def, NOT_LESS] + \\ Cases_on ‘v’ \\ Cases_on ‘w’ \\ gvs [ref_rel_def] + \\ Cases_on ‘EL n s.refs’ \\ Cases_on ‘EL m t.refs’ + \\ gvs [store_v_same_type_def, state_rel_def] + \\ first_x_assum $ qspec_then `n` assume_tac \\ gvs [ref_rel_def]) + \\ gvs [store_assign_def] + \\ Cases_on ‘v’ \\ Cases_on ‘w’ \\ gvs [ref_rel_def] + \\ ( + Cases_on ‘EL n s.refs’ \\ gvs [Once store_v_same_type_def] + \\ gvs [state_rel_def, EL_LUPDATE] \\ rw [] + >- ( + first_x_assum $ qspec_then ‘n’ assume_tac \\ gvs [] + \\ Cases_on ‘EL m t.refs’ \\ gvs [ref_rel_def, store_v_same_type_def]) + >- simp [ref_rel_def] + >- ( + first_x_assum $ qspec_then ‘n'’ assume_tac \\ gvs [] + \\ qpat_x_assum ‘INJ ($' fr) _ _’ mp_tac + \\ qpat_x_assum ‘FLOOKUP fr n = SOME m’ mp_tac + \\ qpat_x_assum ‘FLOOKUP fr n' = SOME m'’ mp_tac + \\ rw [INJ_DEF, FLOOKUP_DEF] \\ gvs []) + >- ( + gvs [NOT_LESS] + \\ qpat_x_assum ‘INJ ($' fr) _ _’ mp_tac + \\ rw [INJ_DEF, FLOOKUP_DEF] \\ gvs [])) QED Theorem v_rel_v_to_list: @@ -858,7 +858,6 @@ Theorem do_app_update: res_rel (v_rel fr1 ft1 fe1) (v_rel fr1 ft1 fe1) res res1) res res1 Proof - cheat (* strip_tac \\ Cases_on ‘op = Env_id’ \\ gs [] >- ( @@ -1835,7 +1834,60 @@ Proof "store_v", "v"]] \\ rpt (irule_at Any SUBMAP_REFL) \\ gs [] \\ first_assum (irule_at Any) \\ gs []) - \\ Cases_on ‘op’ \\ gs [] *) + \\ Cases_on ‘∃m. op = ThunkOp (AllocThunk m)’ \\ gs[] + >- ( + Cases_on ‘res’ \\ gvs [do_app_def, AllCaseEqs(), thunk_op_def] + \\ rpt (pairarg_tac \\ gvs []) + >- metis_tac [SUBMAP_REFL] + >- metis_tac [SUBMAP_REFL] + \\ qexists ‘fr |+ (LENGTH s.refs,LENGTH t.refs)’ \\ gvs [] + \\ rpt (irule_at Any SUBMAP_REFL \\ gvs []) + \\ gvs [store_alloc_def] + \\ qexistsl [‘t with refs := t.refs ++ [Thunk m y]’, + ‘s with refs := s.refs ++ [Thunk m x1]’] + \\ gvs [state_rel_def] + \\ rw [] + >- ( + qpat_x_assum ‘INJ ($' fr) _ _’ mp_tac + \\ simp [INJ_DEF, FAPPLY_FUPDATE_THM] + \\ rw [] \\ gvs [] + \\ ntac 2 (first_x_assum drule \\ gvs [])) + >- gvs [count_add1] + >- ( + gvs [FLOOKUP_UPDATE] \\ rw [] + \\ first_x_assum drule \\ rw []) + >- (first_x_assum drule \\ rw []) + >- ( + gvs [FLOOKUP_UPDATE, EL_APPEND_EQN] \\ rw [] \\ gvs [] + >- ( + simp [oneline ref_rel_def] + \\ irule v_rel_update \\ gvs [] + \\ first_x_assum $ irule_at Any \\ gvs []) + >- ( + first_x_assum $ qspec_then ‘n’ assume_tac \\ gvs [] + \\ irule ref_rel_mono \\ gvs [] + \\ first_x_assum $ irule_at Any \\ rw [] + \\ irule v_rel_update \\ gvs [] + \\ first_x_assum $ irule_at Any \\ gvs [])) + >- ( + gvs [FLOOKUP_UPDATE] + \\ first_x_assum $ qspec_then ‘n’ assume_tac \\ gvs []) + >- gvs [v_rel_def, FLOOKUP_UPDATE]) + \\ Cases_on ‘∃m. op = ThunkOp (UpdateThunk m)’ \\ gs[] + >- ( + Cases_on ‘res’ \\ gvs [do_app_def, AllCaseEqs(), thunk_op_def, OPTREL_def] + \\ rpt (irule_at Any SUBMAP_REFL) \\ gs [v_rel_def] + \\ rename1 ‘v_rel fr ft fe v w’ + \\ ‘ref_rel (v_rel fr ft fe) (Thunk m v) (Thunk m w)’ + by gs [ref_rel_def] + \\ drule_all state_rel_store_assign \\ rw [OPTREL_def] + \\ first_assum (irule_at Any) \\ gs []) + \\ Cases_on ‘op = ThunkOp ForceThunk’ \\ gs [] + >- ( + Cases_on ‘res’ \\ gvs [do_app_def, AllCaseEqs(), thunk_op_def] + \\ rpt (irule_at Any SUBMAP_REFL \\ gvs [])) + \\ Cases_on ‘op’ \\ gs [] + \\ Cases_on ‘t'’ \\ gs [] QED (* TODO Move up *) @@ -1869,13 +1921,139 @@ Proof rw[v_rel_def, Boolv_def, stamp_rel_cases] QED +Definition thunk_rel_def: + thunk_rel f BadRef BadRef = T ∧ + thunk_rel f NotThunk NotThunk = T ∧ + thunk_rel f (IsThunk m1 v1) (IsThunk m2 v2) = (m1 = m2 ∧ f v1 v2) ∧ + thunk_rel _ _ _ = F +End + +Theorem state_rel_dest_thunk: + state_rel l fr ft fe s t ∧ + LIST_REL (v_rel fr ft fe) vs ws ∧ + dest_thunk vs s.refs = t1 ⇒ + ∃t2. dest_thunk ws t.refs = t2 ∧ thunk_rel (v_rel fr ft fe) t1 t2 +Proof + rw [] + \\ Cases_on ‘dest_thunk vs s.refs’ + \\ Cases_on ‘dest_thunk ws t.refs’ + \\ gvs [thunk_rel_def, oneline dest_thunk_def, AllCaseEqs(), v_rel_def] + \\ drule_all state_rel_store_lookup \\ rw [OPTREL_def, ref_rel_def] +QED + +Theorem state_rel_update_thunk_NONE: + fr1 ⊑ fr2 ∧ + state_rel l fr2 ft2 fe2 s t ∧ + LIST_REL (v_rel fr1 ft1 fe1) vs1 ws1 ∧ + LIST_REL (v_rel fr2 ft2 fe2) vs2 ws2 ∧ + update_thunk vs1 s.refs vs2 = NONE ⇒ + update_thunk ws1 t.refs ws2 = NONE +Proof + rw [] + \\ gvs [oneline update_thunk_def, AllCaseEqs(), v_rel_def] + \\ ‘LIST_REL (v_rel fr2 ft2 fe2) [v] [y']’ by gvs [] + \\ drule_all state_rel_dest_thunk \\ rw [] \\ gvs [] + \\ Cases_on ‘dest_thunk [y'] t.refs’ \\ gvs [thunk_rel_def] + \\ ‘FLOOKUP fr2 n = SOME l2’ by (drule_all FLOOKUP_SUBMAP \\ rw []) + \\ ‘ref_rel (v_rel fr2 ft2 fe2) (Thunk Evaluated v) (Thunk Evaluated y')’ + by gvs [ref_rel_def] + \\ drule_all state_rel_store_assign \\ rw [] +QED + +Theorem state_rel_update_thunk_SOME: + fr1 ⊑ fr2 ∧ + state_rel l fr2 ft2 fe2 s t ∧ + update_thunk vs1 s.refs vs2 = SOME refs1 ∧ + LIST_REL (v_rel fr1 ft1 fe1) vs1 a1 ∧ + LIST_REL (v_rel fr2 ft2 fe2) vs2 a2 ⇒ + ∃refs2. + (update_thunk a1 t.refs a2 = SOME refs2 ∧ + state_rel l fr2 ft2 fe2 (s with refs := refs1) (t with refs := refs2)) +Proof + rw [] + \\ gvs [oneline update_thunk_def, AllCaseEqs(), v_rel_def] + \\ ‘LIST_REL (v_rel fr2 ft2 fe2) [v] [y']’ by gvs [] + \\ drule_all state_rel_dest_thunk \\ rw [] \\ gvs [] + \\ Cases_on ‘dest_thunk [y'] t.refs’ \\ gvs [thunk_rel_def] + \\ ‘FLOOKUP fr2 n = SOME l2’ by (drule_all FLOOKUP_SUBMAP \\ rw []) + \\ ‘ref_rel (v_rel fr2 ft2 fe2) (Thunk Evaluated v) (Thunk Evaluated y')’ + by gvs [ref_rel_def] + \\ drule_all state_rel_store_assign \\ rw [OPTREL_def] \\ gvs [] +QED + + Theorem evaluate_update_Op: op ≠ Opapp ∧ op ≠ Eval ⇒ ^(get_goal "App") Proof - cheat (* rw [evaluate_def] \\ Cases_on ‘getOpClass op’ - >- (Cases_on ‘op’ \\ gs[]) - >- (Cases_on ‘op’ \\ gs[]) + >- (Cases_on ‘op’ \\ gs[] \\ Cases_on ‘t'’ \\ gs[]) + >- (Cases_on ‘op’ \\ gs[] \\ Cases_on ‘t'’ \\ gs[]) + >- ( + gvs [AllCaseEqs(), PULL_EXISTS] + >>~ [‘dest_thunk vs s1.refs = IsThunk NotEvaluated _’] + >- ( + first_x_assum drule_all \\ rw [] + \\ Cases_on ‘res1’ \\ gvs [] + \\ rpt (goal_assum drule \\ gvs []) + \\ drule_all state_rel_dest_thunk \\ rw [] + \\ Cases_on ‘dest_thunk a t1.refs’ \\ gvs [thunk_rel_def, state_rel_def]) + >- ( + first_x_assum drule_all \\ rw [] + \\ Cases_on ‘res1’ \\ gvs [] + \\ ‘state_rel l fr1 ft1 fe1 (dec_clock s1) (dec_clock t1)’ + by gvs [state_rel_def, dec_clock_def] + \\ drule_all state_rel_dest_thunk \\ rw [] + \\ Cases_on ‘dest_thunk a t1.refs’ \\ gvs [thunk_rel_def] + \\ last_x_assum $ drule_then $ qspec_then ‘sing_env "f" v'’ mp_tac + \\ impl_tac + >- gvs [env_rel_def, ctor_rel_def, sing_env_def, nsAll2_nsBind] + \\ rw [] + \\ goal_assum $ drule_at (Pat ‘state_rel _ _ _ _ _ _’) \\ gvs [] + \\ imp_res_tac SUBMAP_TRANS \\ gvs [] \\ rw [] + >- gvs [state_rel_def] + \\ Cases_on ‘res1’ \\ gvs [] + \\ ‘fr1 ⊑ fr1'’ by gvs [] + \\ drule_all state_rel_update_thunk_NONE \\ gvs []) + >- ( + first_x_assum drule_all \\ rw [] + \\ Cases_on ‘res1’ \\ gvs [] + \\ ‘state_rel l fr1 ft1 fe1 (dec_clock s1) (dec_clock t1)’ + by gvs [state_rel_def, dec_clock_def] + \\ drule_all state_rel_dest_thunk \\ rw [] + \\ Cases_on ‘dest_thunk a t1.refs’ \\ gvs [thunk_rel_def] + \\ last_x_assum $ drule_then $ qspec_then ‘sing_env "f" v'’ mp_tac + \\ impl_tac + >- gvs [env_rel_def, ctor_rel_def, sing_env_def, nsAll2_nsBind] + \\ rw [] + \\ Cases_on ‘res1’ \\ gvs [] + \\ drule_at (Pat ‘update_thunk _ _ _ = _’) state_rel_update_thunk_SOME + \\ disch_then drule_all \\ rw [] \\ gvs [] + \\ ‘fr ⊑ fr1' ∧ ft ⊑ ft1' ∧ fe ⊑ fe1'’ by ( + imp_res_tac SUBMAP_TRANS \\ gvs []) + \\ rpt (goal_assum drule \\ gvs []) + \\ qexists ‘Rval a'’ \\ gvs [state_rel_def]) + >- ( + first_x_assum drule_all \\ rw [] + \\ Cases_on ‘res1’ \\ gvs [] + \\ ‘state_rel l fr1 ft1 fe1 (dec_clock s1) (dec_clock t1)’ + by gvs [state_rel_def, dec_clock_def] + \\ drule_all state_rel_dest_thunk \\ rw [] + \\ Cases_on ‘dest_thunk a t1.refs’ \\ gvs [thunk_rel_def] + \\ last_x_assum $ drule_then $ qspec_then ‘sing_env "f" v'’ mp_tac + \\ impl_tac + >- gvs [env_rel_def, ctor_rel_def, sing_env_def, nsAll2_nsBind] + \\ rw [] + \\ Cases_on ‘res1’ \\ gvs [] + \\ ‘fr ⊑ fr1' ∧ ft ⊑ ft1' ∧ fe ⊑ fe1'’ by ( + imp_res_tac SUBMAP_TRANS \\ gvs []) + \\ rpt (goal_assum drule \\ gvs []) + \\ goal_assum $ drule_at Any \\ gvs [state_rel_def]) + \\ ( + first_x_assum drule_all \\ rw [] + \\ Cases_on ‘res1’ \\ gvs [] + \\ rpt (goal_assum drule \\ gvs []) + \\ drule_all state_rel_dest_thunk \\ rw [] + \\ Cases_on ‘dest_thunk a t1.refs’ \\ gvs [thunk_rel_def])) >- ( gvs [CaseEqs ["prod", "result", "option"], PULL_EXISTS] \\ first_x_assum (drule_all_then strip_assume_tac) @@ -1952,7 +2130,7 @@ Proof \\ last_x_assum $ irule_at Any \\ last_x_assum $ irule_at Any \\ last_x_assum $ irule_at Any - \\ gs [state_rel_def]) *) + \\ gs [state_rel_def]) QED Theorem do_opapp_update: diff --git a/semantics/proofs/fpSemPropsScript.sml b/semantics/proofs/fpSemPropsScript.sml index 82c86db9fa..2eee815655 100644 --- a/semantics/proofs/fpSemPropsScript.sml +++ b/semantics/proofs/fpSemPropsScript.sml @@ -317,7 +317,17 @@ Proof \\ ntac 2 (TOP_CASE_TAC \\ fs[]) >- solve_simple \\ solve_complex) - >- cheat + >- ( + gvs[AllCaseEqs()] + \\ rw[] + >- (first_x_assum drule_all \\ rw[] \\ gvs[] \\ metis_tac[]) + >- (first_x_assum drule_all \\ rw[] \\ gvs[] \\ metis_tac[]) + >- (first_x_assum drule_all \\ rw[] \\ gvs[] \\ metis_tac[]) + >- (first_x_assum drule_all \\ rw[] \\ gvs[] \\ metis_tac[]) + \\ ( + solve_complex + \\ qexists `stC with fp_state := stC.fp_state with opts := hN''` + \\ gvs[])) >- ( TOP_CASE_TAC \\ fs[] >- solve_simple @@ -674,7 +684,21 @@ Proof \\ strip_tac \\ fs[dec_clock_def] \\ solve_complex) (* Force *) - >- cheat + >- ( + gvs[AllCaseEqs()] \\ rw[] \\ gvs[] + >- solve_simple + >- solve_simple + >- solve_simple + >- solve_simple + \\ ( + solve_complex + \\ rw[] \\ gvs[] + \\ qexistsl [ + `fpOpt3N`, + `st2 with fp_state := st2.fp_state with + <| rws := opts; + opts := fpOpt2N |>`] + \\ gvs[])) (* Simple *) >- ( TOP_CASE_TAC \\ fs[] >- solve_simple From d8cea12fe70c909a98be8d261365c6377f2aab30 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 14 Aug 2025 00:33:10 +0300 Subject: [PATCH 045/112] Prove more various cheats outside `compiler/backend` --- compiler/repl/evaluate_initScript.sml | 98 +++++++++++++++++++++++++-- compiler/repl/evaluate_skipScript.sml | 3 +- 2 files changed, 92 insertions(+), 9 deletions(-) diff --git a/compiler/repl/evaluate_initScript.sml b/compiler/repl/evaluate_initScript.sml index 766ff5ac37..9c8cf30f41 100644 --- a/compiler/repl/evaluate_initScript.sml +++ b/compiler/repl/evaluate_initScript.sml @@ -64,7 +64,8 @@ End Theorem ref_ok_thm: ref_ok s (Refv v) = v_ok s v ∧ ref_ok s (Varray vs) = EVERY (v_ok s) vs ∧ - ref_ok s (W8array a) = T + ref_ok s (W8array a) = T ∧ + ref_ok s (Thunk _ v) = v_ok s v Proof rw [ref_ok_def, ref_rel_def, v_ok_def, LIST_REL_EL_EQN, EVERY_EL] QED @@ -349,7 +350,6 @@ Theorem do_app_ok: (∀v. res = Rval v ⇒ v_ok t v) ∧ (∀v. res = Rerr (Rraise v) ⇒ v_ok t v) Proof - cheat (* strip_tac \\ simp [LET_THM] \\ simp [Once CONJ_COMM] \\ simp [Once (GSYM CONJ_ASSOC)] @@ -686,21 +686,105 @@ Proof gvs[do_app_cases, v_ok_thm] \\ ‘s with <| refs := s.refs; ffi := s.ffi |> = s’ suffices_by gs[] \\ gs[state_component_equality]) - \\ Cases_on ‘op’ \\ gs [] *) + \\ Cases_on ‘∃m. op = ThunkOp (AllocThunk m)’ \\ gs[] + >- ( + gvs [do_app_cases, v_ok_thm, thunk_op_def, AllCaseEqs()] + \\ pairarg_tac \\ gvs [] + \\ gvs [store_alloc_def, state_ok_def, v_ok_thm, state_rel_def, EVERY_EL, + INJ_IFF, FLOOKUP_FUN_FMAP, EL_APPEND_EQN] + \\ rw [] \\ gvs [FUN_FMAP_DEF, ref_rel_def, NOT_LESS, LESS_OR_EQ, + ref_ok_def] + >- ( + irule ref_rel_mono + \\ first_assum (irule_at Any) \\ rw [] + \\ irule_at Any v_rel_update + \\ first_assum (irule_at Any) + \\ gvs [FUN_FMAP_SUBMAP_SUBSET, COUNT_MONO]) + \\ gvs [v_ok_def] + \\ irule_at Any v_rel_update + \\ first_assum (irule_at Any) + \\ gvs [FUN_FMAP_SUBMAP_SUBSET, COUNT_MONO]) + \\ Cases_on ‘∃m. op = ThunkOp (UpdateThunk m)’ \\ gs[] + >- ( + gvs [do_app_cases, thunk_op_def, AllCaseEqs(), v_ok_thm, store_assign_def, + state_ok_def, v_ok_def, state_rel_def, FLOOKUP_FUN_FMAP] + \\ rw [v_rel_def, EL_LUPDATE, ref_rel_def]) + \\ Cases_on ‘op = ThunkOp ForceThunk’ \\ gs[] + >- gvs [do_app_def, AllCaseEqs(), thunk_op_def] + \\ Cases_on ‘op’ \\ gs [] + \\ Cases_on ‘t’ \\ gs [] QED Theorem do_app_ok[allow_rebind] = SIMP_RULE (srw_ss()) [LET_THM] do_app_ok; +Theorem dest_thunk_ok: + state_ok s ∧ + dest_thunk vs s.refs = IsThunk m v ⇒ + state_ok (dec_clock s) ∧ env_ok (dec_clock s) (sing_env n v) +Proof + rw [] + >- gvs [dec_clock_def, state_ok_def, state_rel_def] + \\ gvs [dec_clock_def, sing_env_def, env_ok_def, env_rel_def, ctor_rel_def] + \\ irule nsAll2_nsBind \\ rw [] \\ gvs [] + \\ gvs [state_ok_def, state_rel_def, FLOOKUP_FUN_FMAP] + \\ gvs [oneline dest_thunk_def, AllCaseEqs(), store_lookup_def] + \\ first_x_assum drule \\ rw [ref_rel_def] +QED + Theorem evaluate_ok_Op: op ≠ Opapp ∧ op ≠ Eval ⇒ ^(get_goal "App") Proof - cheat (* strip_tac - \\ ‘~ (getOpClass op = EvalOp)’ by (Cases_on ‘op’ \\ gs[]) - \\ ‘~ (getOpClass op = FunApp)’ by (Cases_on ‘op’ \\ gs[]) + \\ ‘~ (getOpClass op = EvalOp)’ by ( + Cases_on ‘op’ \\ gs[] \\ Cases_on ‘t’ \\ gs[]) + \\ ‘~ (getOpClass op = FunApp)’ by ( + Cases_on ‘op’ \\ gs[] \\ Cases_on ‘t’ \\ gs[]) \\ rpt strip_tac \\ gs[evaluate_def, Excl "getOpClass_def"] \\ Cases_on ‘getOpClass op’ \\ gs[Excl "getOpClass_def"] + >>~ [‘getOpClass op = Force’] + >- ( + Cases_on ‘op’ \\ full_simp_tac (srw_ss()) [] + \\ Cases_on ‘t'’ \\ full_simp_tac (srw_ss()) [AllCaseEqs()] \\ gvs [] + >- ( + drule_all_then (qspec_then ‘"f"’ assume_tac) dest_thunk_ok \\ gvs [] + \\ qpat_x_assum ‘state_ok st2’ mp_tac + \\ rw [state_ok_def, state_rel_def] \\ gvs [FLOOKUP_FUN_FMAP] + >- simp [INJ_DEF, FUN_FMAP_DEF] + \\ rw [] + \\ gvs [oneline update_thunk_def, AllCaseEqs(), store_assign_def, + EL_LUPDATE] + \\ IF_CASES_TAC \\ gvs [ref_rel_def, v_ok_def]) + >- ( + drule_all_then (qspec_then ‘"f"’ assume_tac) dest_thunk_ok \\ gvs [])) + >- ( + Cases_on ‘op’ \\ full_simp_tac (srw_ss()) [] + \\ Cases_on ‘t'’ \\ full_simp_tac (srw_ss()) [AllCaseEqs()] \\ gvs [] + \\ ( + drule_all_then (qspec_then ‘"f"’ assume_tac) dest_thunk_ok \\ gvs [] + \\ imp_res_tac (CONJUNCT1 evaluate_next_type_stamp_mono) + \\ imp_res_tac (CONJUNCT1 evaluate_next_exn_stamp_mono) + \\ imp_res_tac (CONJUNCT1 evaluate_refs_length_mono) + \\ gvs [dec_clock_def, env_ok_def] + \\ irule env_rel_update + \\ first_assum (irule_at Any) + \\ gvs [oneline update_thunk_def, AllCaseEqs(), store_assign_def, + FUN_FMAP_SUBMAP_SUBSET, COUNT_MONO])) + >- ( + Cases_on ‘op’ \\ full_simp_tac (srw_ss()) [] + \\ Cases_on ‘t'’ \\ full_simp_tac (srw_ss()) [AllCaseEqs()] \\ gvs [] + >- ( + gvs [oneline dest_thunk_def, AllCaseEqs(), store_lookup_def] + \\ qpat_x_assum ‘state_ok st'’ mp_tac + \\ rw [state_ok_def, state_rel_def] \\ gvs [FLOOKUP_FUN_FMAP] + \\ first_x_assum drule \\ rw [ref_rel_def, v_ok_def]) + \\ drule_all_then (qspec_then ‘"f"’ assume_tac) dest_thunk_ok \\ gvs [] + \\ gvs [EVERY_EL, v_ok_def, oneline update_thunk_def, AllCaseEqs(), + store_assign_def]) + >- ( + Cases_on ‘op’ \\ full_simp_tac (srw_ss()) [] + \\ Cases_on ‘t'’ \\ full_simp_tac (srw_ss()) [AllCaseEqs()] \\ gvs [] + \\ drule_all_then (qspec_then ‘"f"’ assume_tac) dest_thunk_ok \\ gvs []) \\ gvs [CaseEqs ["prod", "result", "option"]] \\ dxrule_then assume_tac (iffRL EVERY_REVERSE) \\ TRY ( @@ -724,7 +808,7 @@ Proof \\ every_case_tac \\ gs[] \\ rveq \\ gs[]) \\ irule env_rel_update \\ first_assum (irule_at Any) - \\ gs [FUN_FMAP_SUBMAP_SUBSET, COUNT_MONO] *) + \\ gs [FUN_FMAP_SUBMAP_SUBSET, COUNT_MONO] QED Theorem do_opapp_cases[local] = semanticPrimitivesPropsTheory.do_opapp_cases; diff --git a/compiler/repl/evaluate_skipScript.sml b/compiler/repl/evaluate_skipScript.sml index 5f15a45d20..f00aa11021 100644 --- a/compiler/repl/evaluate_skipScript.sml +++ b/compiler/repl/evaluate_skipScript.sml @@ -1957,7 +1957,7 @@ Proof \\ ‘FLOOKUP fr2 n = SOME l2’ by (drule_all FLOOKUP_SUBMAP \\ rw []) \\ ‘ref_rel (v_rel fr2 ft2 fe2) (Thunk Evaluated v) (Thunk Evaluated y')’ by gvs [ref_rel_def] - \\ drule_all state_rel_store_assign \\ rw [] + \\ drule_all state_rel_store_assign \\ rw [OPTREL_def] QED Theorem state_rel_update_thunk_SOME: @@ -1981,7 +1981,6 @@ Proof \\ drule_all state_rel_store_assign \\ rw [OPTREL_def] \\ gvs [] QED - Theorem evaluate_update_Op: op ≠ Opapp ∧ op ≠ Eval ⇒ ^(get_goal "App") Proof From 5bcb10a2890cafe59eb23681f6a9dbb0eeb5624a Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 14 Aug 2025 12:00:33 +0300 Subject: [PATCH 046/112] Prove more various cheats outside `compiler/backend` --- candle/prover/candle_basis_evaluateScript.sml | 4 +- candle/prover/candle_kernel_funsScript.sml | 3 +- .../prover/candle_prover_evaluateScript.sml | 118 +++++++++++++++++- candle/prover/candle_prover_invScript.sml | 3 +- 4 files changed, 117 insertions(+), 11 deletions(-) diff --git a/candle/prover/candle_basis_evaluateScript.sml b/candle/prover/candle_basis_evaluateScript.sml index 6c1541a659..f7e7d9e639 100644 --- a/candle/prover/candle_basis_evaluateScript.sml +++ b/candle/prover/candle_basis_evaluateScript.sml @@ -217,7 +217,6 @@ QED Theorem evaluate_basis_v_ok_App: ^(get_goal "App") Proof - cheat (* rw [evaluate_def] \\ Cases_on ‘getOpClass op’ \\ gvs [CaseEqs ["bool", "option", "prod", "semanticPrimitives$result"], SF SFY_ss] @@ -225,6 +224,7 @@ Proof >- (Cases_on ‘op’ \\ gs[]) >- (Cases_on ‘op’ \\ gs[]) >- (Cases_on ‘op’ \\ gs[]) + >- (Cases_on ‘op’ \\ gvs []) >- ( gvs [do_app_cases, Boolv_def] \\ rw [v_ok_def] @@ -239,7 +239,7 @@ Proof \\ first_x_assum irule \\ gs [] \\ gs [post_state_ok_def])) >- (Cases_on ‘op’ \\ gs[]) - >- (Cases_on ‘op’ \\ gs[]) *) + >- (Cases_on ‘op’ \\ gs[]) QED Theorem evaluate_basis_v_ok_FpOptimise: diff --git a/candle/prover/candle_kernel_funsScript.sml b/candle/prover/candle_kernel_funsScript.sml index 3bc81f6183..b0b58a7edf 100644 --- a/candle/prover/candle_kernel_funsScript.sml +++ b/candle/prover/candle_kernel_funsScript.sml @@ -451,9 +451,8 @@ Theorem ref_ok_APPEND: !x s. STATE (x ++ c) s /\ (!th. THM c th ==> THM (x ++ c) th) ==> ref_ok (x ++ c) v Proof - cheat (* gen_tac \\ Cases \\ rw[ref_ok_def] - \\ fs[EVERY_MEM] \\ metis_tac[v_ok_APPEND] *) + \\ fs[EVERY_MEM] \\ metis_tac[v_ok_APPEND] QED Theorem inferred_ok: diff --git a/candle/prover/candle_prover_evaluateScript.sml b/candle/prover/candle_prover_evaluateScript.sml index b12ce30abd..1a25a7f1c0 100644 --- a/candle/prover/candle_prover_evaluateScript.sml +++ b/candle/prover/candle_prover_evaluateScript.sml @@ -285,7 +285,6 @@ Theorem do_app_ok: | Rerr (Rraise v) => v_ok ctxt v | _ => T Proof - cheat (* strip_tac \\ qpat_x_assum ‘do_app _ _ _ = _’ mp_tac \\ Cases_on ‘op = Env_id’ \\ gs [] @@ -662,16 +661,123 @@ Proof rw[do_app_cases] \\ gs [SF SFY_ss] \\ first_assum (irule_at Any) \\ simp [v_ok_def]) - \\ Cases_on ‘op’ \\ gs [] *) + \\ Cases_on ‘∃m. op = ThunkOp (AllocThunk m)’ \\ gs[] + >- ( + rw [do_app_cases] \\ gs [thunk_op_def, AllCaseEqs()] + \\ pairarg_tac \\ gvs [] + \\ gvs [v_ok_def, store_alloc_def, EVERY_EL, LLOOKUP_EQ_EL] + \\ first_assum (irule_at Any) \\ gs [] + \\ rw [EL_APPEND_EQN] \\ gs [NOT_LESS, LESS_OR_EQ, ref_ok_def] + >- ( + gs [kernel_loc_ok_def, LLOOKUP_EQ_EL, EL_APPEND_EQN] + \\ first_x_assum (drule_then strip_assume_tac) + \\ rw [] \\ gs [SF SFY_ss]) + \\ strip_tac + \\ first_x_assum (drule_then assume_tac) + \\ drule kernel_loc_ok_LENGTH \\ gs []) + \\ Cases_on ‘∃m. op = ThunkOp (UpdateThunk m)’ \\ gs[] + >- ( + rw [do_app_cases] \\ gs [thunk_op_def, AllCaseEqs()] + \\ first_assum (irule_at Any) + \\ gvs [v_ok_def, store_assign_def, EVERY_EL, EL_LUPDATE, LLOOKUP_EQ_EL] + \\ rw [ref_ok_def] + \\ irule kernel_loc_ok_LUPDATE1 + \\ rpt strip_tac \\ gs []) + \\ Cases_on ‘op = ThunkOp ForceThunk’ \\ gs[] + >- (rw [do_app_cases] \\ gs [thunk_op_def]) + \\ Cases_on ‘op’ \\ gs [] + \\ Cases_on ‘t’ \\ gs [] +QED + +Theorem state_ok_dest_thunk: + state_ok ctxt s ∧ + EVERY (v_ok ctxt) vs ∧ + dest_thunk vs s.refs = IsThunk m v ⇒ + v_ok ctxt v ∧ env_ok ctxt (sing_env n v) +Proof + rw [] + >- ( + gvs [state_ok_def, oneline dest_thunk_def, AllCaseEqs(), v_ok_def, + store_lookup_def, LLOOKUP_THM] + \\ first_x_assum drule \\ rw [] \\ gvs [ref_ok_def]) + \\ rw [env_ok_def, sing_env_def] + \\ Cases_on ‘n'’ \\ gvs [] + \\ gvs [namespaceTheory.nsEmpty_def, namespaceTheory.nsBind_def, + namespaceTheory.nsLookup_def] + \\ gvs [oneline dest_thunk_def, AllCaseEqs(), store_lookup_def, state_ok_def, + LLOOKUP_THM, v_ok_def] + \\ first_x_assum drule_all \\ rw [] \\ gvs [ref_ok_def] +QED + +Theorem state_ok_update_thunk: + state_ok ctxt s ∧ + EVERY (v_ok ctxt) vs ∧ + EVERY (v_ok ctxt) vs2 ∧ + update_thunk vs s.refs vs2 = SOME refs ⇒ + state_ok ctxt (s with refs := refs) +Proof + rw [] + \\ gvs [oneline update_thunk_def, AllCaseEqs(), store_assign_def, + state_ok_def, LLOOKUP_LUPDATE, v_ok_def] + \\ goal_assum drule \\ gvs [] \\ rw [] + >- ( + irule kernel_loc_ok_LUPDATE1 \\ gvs [] + \\ metis_tac [EXTENSION]) + >- (first_x_assum drule \\ rw []) + >- gvs [ref_ok_def] QED Theorem evaluate_v_ok_Op: op ≠ Opapp ∧ op ≠ Eval ⇒ ^(get_goal "ast$App") Proof - cheat (* rw [evaluate_def] \\ Cases_on ‘getOpClass op’ \\ gs[] - >~ [‘EvalOp’] >- (Cases_on ‘op’ \\ gs[]) - >~ [‘FunApp’] >- (Cases_on ‘op’ \\ gs[]) + >~ [‘EvalOp’] >- (Cases_on ‘op’ \\ gs[] \\ Cases_on ‘t’ \\ gs[]) + >~ [‘FunApp’] >- (Cases_on ‘op’ \\ gs[] \\ Cases_on ‘t’ \\ gs[]) + >~ [‘Force’] >- ( + gvs [AllCaseEqs()] + >~ [‘BadRef’] >- ( + first_x_assum (drule_all_then strip_assume_tac) \\ gvs [state_ok_def]) + >~ [‘NotThunk’] >- ( + first_x_assum (drule_all_then strip_assume_tac) \\ gvs [state_ok_def]) + >~ [‘IsThunk NotEvaluated _’, ‘s'.clock = 0’] >- ( + first_x_assum (drule_all_then strip_assume_tac) \\ gvs [state_ok_def]) + >- ( + first_x_assum (drule_all_then strip_assume_tac) \\ gvs [] + \\ goal_assum drule \\ gvs [] + \\ drule_all state_ok_dest_thunk \\ rw []) + >- ( + first_x_assum (drule_all_then strip_assume_tac) \\ gvs [] + \\ goal_assum drule \\ gvs [] + \\ rename1 ‘state_ok ctxt1 st'’ + \\ ‘state_ok ctxt1 (dec_clock st')’ by ( + gvs [state_ok_def, dec_clock_def] \\ metis_tac []) + \\ last_x_assum drule + \\ impl_tac \\ rw [] + >- (drule_all state_ok_dest_thunk \\ rw []) + >- gvs [AppUnit_def, safe_exp_def] + >- gvs [state_ok_def]) + >- ( + first_x_assum (drule_all_then strip_assume_tac) \\ gvs [] + \\ rename1 ‘state_ok ctxt1 st'’ + \\ ‘state_ok ctxt1 (dec_clock st')’ by ( + gvs [state_ok_def, dec_clock_def] \\ metis_tac []) + \\ last_x_assum drule + \\ impl_tac \\ rw [] + >- (drule_all state_ok_dest_thunk \\ rw []) + >- gvs [AppUnit_def, safe_exp_def] + \\ qexists ‘ctxt''’ \\ gvs [] + \\ ‘EVERY (v_ok ctxt'') vs’ by gvs [EVERY_EL] + \\ drule_all state_ok_update_thunk \\ rw []) + >- ( + first_x_assum (drule_all_then strip_assume_tac) \\ gvs [] + \\ rename1 ‘state_ok ctxt1 st'’ + \\ ‘state_ok ctxt1 (dec_clock st')’ by ( + gvs [state_ok_def, dec_clock_def] \\ metis_tac []) + \\ last_x_assum drule + \\ impl_tac \\ rw [] + >- (drule_all state_ok_dest_thunk \\ rw []) + >- gvs [AppUnit_def, safe_exp_def] + >- metis_tac [])) >~ [‘Simple’] >- ( gvs [AllCaseEqs()] \\ first_x_assum (drule_all_then strip_assume_tac) \\ gs [state_ok_def] @@ -705,7 +811,7 @@ Proof \\ disch_then drule_all \\ simp [] \\ strip_tac \\ gs [] \\ rpt CASE_TAC \\ gs [] - \\ first_assum (irule_at Any) \\ gs []) *) + \\ first_assum (irule_at Any) \\ gs []) QED Theorem evaluate_v_ok_Opapp: diff --git a/candle/prover/candle_prover_invScript.sml b/candle/prover/candle_prover_invScript.sml index f962269edb..405a24472d 100644 --- a/candle/prover/candle_prover_invScript.sml +++ b/candle/prover/candle_prover_invScript.sml @@ -221,7 +221,8 @@ Theorem kernel_vals_ind = v_ok_ind Definition ref_ok_def: ref_ok ctxt (Varray vs) = EVERY (v_ok ctxt) vs ∧ ref_ok ctxt (Refv v) = v_ok ctxt v ∧ - ref_ok ctxt (W8array vs) = T + ref_ok ctxt (W8array vs) = T ∧ + ref_ok ctxt (Thunk m v) = v_ok ctxt v End Definition kernel_loc_ok_def: From 31a312a6404476e81c00e187745339c497c0e282 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 14 Aug 2025 13:00:31 +0300 Subject: [PATCH 047/112] Prove all cheats in `bvlProps` --- compiler/backend/semantics/bvlPropsScript.sml | 62 +++++++------------ 1 file changed, 21 insertions(+), 41 deletions(-) diff --git a/compiler/backend/semantics/bvlPropsScript.sml b/compiler/backend/semantics/bvlPropsScript.sml index 0ad96d11cd..ca66d680b3 100644 --- a/compiler/backend/semantics/bvlPropsScript.sml +++ b/compiler/backend/semantics/bvlPropsScript.sml @@ -355,19 +355,10 @@ Proof \\ pop_assum (assume_tac o GSYM) \\ fs [] \\ qexists_tac `n` \\ fs [dec_clock_def]) THEN1 - cheat (* - - gvs [AllCaseEqs()] \\ rw [] \\ fs [] - >~ [`dest_thunk _ _ = BadRef`] >- (qexists `n` \\ gvs []) - >~ [`dest_thunk _ _ = NotThunk`] >- (qexists `n` \\ gvs []) - >~ [`dest_thunk _ _ = IsThunk Evaluated _`] >- (qexists `n` \\ gvs []) - >~ [`dest_thunk _ _ = IsThunk NotEvaluated _`] >- (qexists `n` \\ gvs []) - \\ qexists `n' + n` - \\ rewrite_tac [GENLIST_APPEND,FOLDL_APPEND,MAP_APPEND] - \\ fs [dec_clock_def,shift_seq_def,FUN_EQ_THM] - \\ simp_tac std_ss [Once ADD_COMM] \\ fs []) - -*) + (rw [] \\ gvs [AllCaseEqs(), NOT_LESS] + >~ [‘dest_thunk _ _ = IsThunk NotEvaluated _’, ‘find_code _ _ _ = SOME _’] + >- (qexists ‘n'’ \\ gvs [shift_seq_def, dec_clock_def]) + \\ qexists ‘0’ \\ gvs [shift_seq_def, FUN_EQ_THM]) \\ fs [case_eq_thms] \\ rw [] \\ fs [] \\ TRY (qexists_tac `n` \\ fs [] \\ NO_TAC) \\ pop_assum (assume_tac o GSYM) \\ fs [] @@ -533,7 +524,6 @@ Theorem evaluate_add_clock: ⇒ !ck. evaluate (exps,env,inc_clock ck s1) = (res, inc_clock ck s2) Proof - cheat (* recInduct evaluate_ind >> srw_tac[][evaluate_def] >- (Cases_on `evaluate ([x], env,s)` >> full_simp_tac(srw_ss())[] >> @@ -554,29 +544,23 @@ Proof >- (Cases_on `evaluate ([x1],env,s1)` >> full_simp_tac(srw_ss())[] >> Cases_on `q` >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >> Cases_on`e`>>full_simp_tac(srw_ss())[]>>srw_tac[][]>>full_simp_tac(srw_ss())[]) - >- ( - gvs [AllCaseEqs(), inc_clock_def, dec_clock_def] >> - imp_res_tac do_app_const >> gvs [] >> - imp_res_tac do_app_change_clock >> gvs [] >> - imp_res_tac do_app_change_clock_err >> gvs []) + >- (gvs [AllCaseEqs(), inc_clock_def, dec_clock_def] >> + imp_res_tac do_app_const >> gvs [] >> + imp_res_tac do_app_change_clock >> gvs [] >> + imp_res_tac do_app_change_clock_err >> gvs []) >- (srw_tac[][] >> full_simp_tac(srw_ss())[inc_clock_def, dec_clock_def] >> srw_tac[][] >> `s.clock + ck - 1 = s.clock - 1 + ck` by (srw_tac [ARITH_ss] [ADD1]) >> metis_tac []) - >- (Cases_on `evaluate (xs,env,s1)` >> - full_simp_tac(srw_ss())[] >> - Cases_on `q` >> - full_simp_tac(srw_ss())[] >> - srw_tac[][] >> - BasicProvers.EVERY_CASE_TAC >> - full_simp_tac(srw_ss())[] >> - srw_tac[][] >> - rev_full_simp_tac(srw_ss())[inc_clock_def, dec_clock_def] >> - srw_tac[][] - >- decide_tac >> - `r.clock + ck - (ticks + 1) = r.clock - (ticks + 1) + ck` by srw_tac [ARITH_ss] [ADD1] >> - metis_tac []) *) + >- (gvs [AllCaseEqs(), inc_clock_def, dec_clock_def] >> + imp_res_tac do_app_const >> gvs [] >> + imp_res_tac do_app_change_clock >> gvs [] >> + imp_res_tac do_app_change_clock_err >> gvs []) + >- (gvs [AllCaseEqs(), inc_clock_def, dec_clock_def] >> + imp_res_tac do_app_const >> gvs [] >> + imp_res_tac do_app_change_clock >> gvs [] >> + imp_res_tac do_app_change_clock_err >> gvs []) QED Theorem evaluate_add_clock_initial_state: @@ -607,12 +591,11 @@ Theorem evaluate_io_events_mono: ⇒ s1.ffi.io_events ≼ s2.ffi.io_events Proof - cheat (* recInduct evaluate_ind >> srw_tac[][evaluate_def] >> - every_case_tac >> full_simp_tac(srw_ss())[] >> + gvs [AllCaseEqs()] >> srw_tac[][] >> rev_full_simp_tac(srw_ss())[] >> - metis_tac[IS_PREFIX_TRANS,do_app_io_events_mono] *) + metis_tac[IS_PREFIX_TRANS,do_app_io_events_mono] QED Triviality do_app_inc_clock: @@ -648,7 +631,6 @@ Theorem evaluate_add_to_clock_io_events_mono: (SND(evaluate(exps,env,s))).ffi.io_events ≼ (SND(evaluate(exps,env,inc_clock extra s))).ffi.io_events Proof - cheat (* recInduct evaluate_ind >> srw_tac[][evaluate_def] >> TRY ( @@ -664,9 +646,8 @@ Proof imp_res_tac do_app_io_events_mono >> TRY(fsrw_tac[ARITH_ss][] >>NO_TAC) >> full_simp_tac(srw_ss())[dec_clock_inc_clock] >> - TRY (rename1 `dest_thunk _ _ = _` >> gvs [dec_clock_def, inc_clock_def]) >> metis_tac[evaluate_io_events_mono,SND,IS_PREFIX_TRANS,Boolv_11,PAIR, - inc_clock_ffi,dec_clock_ffi] *) + inc_clock_ffi,dec_clock_ffi] QED Triviality take_drop_lem: @@ -775,14 +756,13 @@ QED Triviality evaluate_refs_SUBSET_lemma: !xs env s. FDOM s.refs SUBSET FDOM (SND (evaluate (xs,env,s))).refs Proof - cheat (* recInduct evaluate_ind \\ REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[evaluate_def] \\ BasicProvers.EVERY_CASE_TAC \\ full_simp_tac(srw_ss())[] \\ REV_FULL_SIMP_TAC std_ss [] \\ IMP_RES_TAC SUBSET_TRANS - \\ gvs [oneline update_thunk_def, AllCaseEqs(), store_thunk_def] \\ full_simp_tac(srw_ss())[dec_clock_def] \\ full_simp_tac(srw_ss())[] - \\ IMP_RES_TAC do_app_refs_SUBSET \\ full_simp_tac(srw_ss())[SUBSET_DEF] *) + \\ IMP_RES_TAC do_app_refs_SUBSET \\ full_simp_tac(srw_ss())[SUBSET_DEF] + \\ rw [] \\ rpt (CASE_TAC \\ rw []) QED Theorem evaluate_refs_SUBSET: From 54c0395e531717321a7c8046c5cbaf078e13cbdf Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 14 Aug 2025 13:14:20 +0300 Subject: [PATCH 048/112] Fix `bviProps` --- compiler/backend/semantics/bviPropsScript.sml | 43 ++++++++----------- 1 file changed, 19 insertions(+), 24 deletions(-) diff --git a/compiler/backend/semantics/bviPropsScript.sml b/compiler/backend/semantics/bviPropsScript.sml index 1a6a56ed43..46bb6c25a8 100644 --- a/compiler/backend/semantics/bviPropsScript.sml +++ b/compiler/backend/semantics/bviPropsScript.sml @@ -344,14 +344,13 @@ Proof \\ `(inc_clock n s).clock <> 0` by (EVAL_TAC \\ DECIDE_TAC) \\ full_simp_tac(srw_ss())[dec_clock_inv_clock1] \\ NO_TAC) THEN1 - (Cases_on `op = ThunkOp ForceThunk` - >- gvs [AllCaseEqs(), dec_clock_def, inc_clock_def] - \\ `?res5 s5. evaluate (xs,env,s) = (res5,s5)` by METIS_TAC [PAIR] + (`?res5 s5. evaluate (xs,env,s) = (res5,s5)` by METIS_TAC [PAIR] \\ full_simp_tac(srw_ss())[] \\ Cases_on `res5` \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] \\ TRY (Cases_on`e` \\ full_simp_tac(srw_ss())[] \\ NO_TAC) \\ MP_TAC (do_app_inv_clock |> Q.INST [`s`|->`s5`]) \\ Cases_on `do_app op (REVERSE a) s5` \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] \\ Cases_on `a'` \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] []) + THEN1 gvs [AllCaseEqs(), NOT_LESS, dec_clock_def, inc_clock_def] THEN1 (Cases_on `dest = NONE /\ IS_SOME handler` \\ full_simp_tac(srw_ss())[] \\ Cases_on `evaluate (xs,env,s1)` \\ full_simp_tac(srw_ss())[] @@ -413,24 +412,21 @@ Proof \\ qexists_tac`a3+a2+a1` \\ simp[GENLIST_APPEND,FOLDL_APPEND] \\ NO_TAC) >- ( - gvs [AllCaseEqs(), FUN_EQ_THM] - >~ [`dest_thunk _ _ = BadRef`] >- (qexists `n` \\ gvs []) - >~ [`dest_thunk _ _ = NotThunk`] >- (qexists `n` \\ gvs []) - >~ [`dest_thunk _ _ = IsThunk Evaluated _`] >- (qexists `n` \\ gvs []) - >~ [`dest_thunk _ _ = IsThunk NotEvaluated _`] >- (qexists `n` \\ gvs []) - \\ qexists `n' + n` - \\ rewrite_tac [GENLIST_APPEND,FOLDL_APPEND,MAP_APPEND] - \\ gvs []) - \\ Cases_on`op=Install` + Cases_on`op=Install` + >- ( + fs[do_app_def,do_install_def,case_eq_thms,bool_case_eq] + \\ pairarg_tac \\ fs[] \\ rveq + \\ fs[case_eq_thms,pair_case_eq,bool_case_eq] \\ rveq + \\ fs[shift_seq_def] + \\ qexists_tac`1+n` \\ rfs[GENLIST_APPEND,FOLDL_APPEND] ) + \\ imp_res_tac do_app_code \\ rfs[] + \\ imp_res_tac do_app_oracle \\ rfs[] + \\ qexists_tac`n` \\ fs[]) >- ( - fs[do_app_def,do_install_def,case_eq_thms,bool_case_eq] - \\ pairarg_tac \\ fs[] \\ rveq - \\ fs[case_eq_thms,pair_case_eq,bool_case_eq] \\ rveq - \\ fs[shift_seq_def] - \\ qexists_tac`1+n` \\ rfs[GENLIST_APPEND,FOLDL_APPEND] ) - \\ imp_res_tac do_app_code \\ rfs[] - \\ imp_res_tac do_app_oracle \\ rfs[] - \\ qexists_tac`n` \\ fs[] + gvs [AllCaseEqs(), FUN_EQ_THM] + >~ [‘dest_thunk _ _ = IsThunk NotEvaluated _’, ‘find_code _ _ _ = SOME _’] + >- (qexists ‘n'’ \\ gvs []) + \\ qexists `0` \\ gvs []) QED Theorem evaluate_code_mono: @@ -558,9 +554,7 @@ Proof srw_tac[][] >> full_simp_tac(srw_ss())[]) >- (Cases_on `evaluate ([x1],env,s)` >> full_simp_tac(srw_ss())[] >> Cases_on `q` >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[]) - >- (Cases_on `op = ThunkOp ForceThunk` - >- gvs [AllCaseEqs(), dec_clock_def, inc_clock_def] >> - Cases_on `evaluate (xs,env,s)` >> full_simp_tac(srw_ss())[] >> + >- (Cases_on `evaluate (xs,env,s)` >> full_simp_tac(srw_ss())[] >> Cases_on `q` >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >> srw_tac[][inc_clock_def] >> BasicProvers.EVERY_CASE_TAC >> @@ -574,6 +568,7 @@ Proof srw_tac[][] >> `s.clock + ck - 1 = s.clock - 1 + ck` by (srw_tac [ARITH_ss] [ADD1]) >> metis_tac []) + >- gvs [AllCaseEqs(), dec_clock_def, inc_clock_def] >- (Cases_on `evaluate (xs,env,s1)` >> full_simp_tac(srw_ss())[] >> Cases_on `q` >> @@ -616,7 +611,7 @@ Theorem evaluate_io_events_mono: Proof recInduct evaluate_ind >> srw_tac[][evaluate_def] >> - every_case_tac >> full_simp_tac(srw_ss())[] >> + gvs [AllCaseEqs()] >> srw_tac[][] >> rev_full_simp_tac(srw_ss())[] >> metis_tac[IS_PREFIX_TRANS,do_app_io_events_mono] QED From 72aa310dd00ef557db0ab7c109a784ddc9e2dc7c Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Fri, 15 Aug 2025 02:52:07 +0300 Subject: [PATCH 049/112] Fix `clos_to_bvlProof` and thunk code in `clos_to_bvl`. TODO cleanup --- compiler/backend/clos_to_bvlScript.sml | 6 +- .../backend/proofs/bvi_letProofScript.sml | 2 + .../backend/proofs/bvi_tailrecProofScript.sml | 42 ++--- .../backend/proofs/clos_to_bvlProofScript.sml | 147 +++++++++++++++++- 4 files changed, 162 insertions(+), 35 deletions(-) diff --git a/compiler/backend/clos_to_bvlScript.sml b/compiler/backend/clos_to_bvlScript.sml index 0d49e544c5..cd68ed36f2 100644 --- a/compiler/backend/clos_to_bvlScript.sml +++ b/compiler/backend/clos_to_bvlScript.sml @@ -402,10 +402,10 @@ End Definition force_thunk_code_def: force_thunk_code = - If (Op (BlockOp (EqualConst (Int 0))) [mk_elem_at (Var 0) 1]) - (Let [Call 0 NONE [mk_unit; Var 0; mk_elem_at (Var 0) 0]] + If (Op (BlockOp (EqualConst (Int 0))) [mk_elem_at (Var 1) 1]) + (Let [Call 0 NONE [mk_unit; Var 1; mk_elem_at (Var 1) 0]] (Let [Op (ThunkOp (UpdateThunk Evaluated)) [Var 0; Var 1]] (Var 1))) - (Let [Call 0 (SOME 0) [mk_unit; Var 0]] + (Let [Call 0 (SOME 0) [mk_unit; Var 1]] (Let [Op (ThunkOp (UpdateThunk Evaluated)) [Var 0; Var 1]] (Var 1))) : bvl$exp End diff --git a/compiler/backend/proofs/bvi_letProofScript.sml b/compiler/backend/proofs/bvi_letProofScript.sml index 8e22e2c6cb..cc8170b3df 100644 --- a/compiler/backend/proofs/bvi_letProofScript.sml +++ b/compiler/backend/proofs/bvi_letProofScript.sml @@ -257,6 +257,8 @@ Proof \\ pop_assum $ drule_at $ Pos $ el 2 \\ gvs [] \\ disch_then drule \\ impl_tac >- (CCONTR_TAC \\ gvs []) \\ gvs []) + \\ Cases_on `∃force_loc n. h = Force force_loc n` \\ gvs [] + THEN1 cheat \\ reverse (Cases_on `?ys y. h = Let ys y` \\ fs []) THEN1 (Cases_on `h` \\ fs []) \\ fs [] \\ rpt (qpat_x_assum `T` kall_tac) \\ rveq \\ fs [evaluate_def] diff --git a/compiler/backend/proofs/bvi_tailrecProofScript.sml b/compiler/backend/proofs/bvi_tailrecProofScript.sml index 16c70c48f8..9bdd1b22ec 100644 --- a/compiler/backend/proofs/bvi_tailrecProofScript.sml +++ b/compiler/backend/proofs/bvi_tailrecProofScript.sml @@ -559,16 +559,13 @@ Proof \\ rfs [EL_APPEND1, EL_APPEND2, EL_LENGTH_APPEND]) (*Op*) \\ CASE_TAC \\ fs [evaluate_def] + >>~- ([‘dest_thunk’], + gvs [AllCaseEqs(), NOT_LESS] + \\ gvs [oneline dest_thunk_def, AllCaseEqs(), ty_rel_def, LIST_REL_EL_EQN] + \\ first_x_assum drule \\ rw [] \\ gvs [bvlSemTheory.v_to_list_def] + \\ metis_tac [evaluate_SING_IMP]) >- - (Cases_on `op = ThunkOp ForceThunk` - >- ( - gvs [AllCaseEqs()] - >- gvs [ty_rel_def] - \\ qspecl_then - [`[AppUnit]`, `[v]`, `dec_clock 1 s'`] assume_tac evaluate_LENGTH - \\ gvs [] - \\ Cases_on `vs` \\ gvs [ty_rel_def]) - \\ rw [case_eq_thms, case_elim_thms, IS_SOME_EXISTS, PULL_EXISTS, bool_case_eq, + (rw [case_eq_thms, case_elim_thms, IS_SOME_EXISTS, PULL_EXISTS, bool_case_eq, pair_case_eq, from_op_def, arg_ty_def, op_ty_def] \\ fs [pair_case_eq, case_elim_thms, case_eq_thms] \\ rw [] \\ fs [] \\ fs [op_type_def, arg_ty_def, ty_rel_def, get_bin_args_def, case_elim_thms, @@ -1633,33 +1630,16 @@ Proof \\ simp [LEFT_EXISTS_AND_THM, CONJ_ASSOC] \\ conj_tac >- - (Cases_on `op = ThunkOp ForceThunk` + ((*Cases_on `op = ThunkOp ForceThunk` >- ( gvs [] \\ last_assum $ qspecl_then [`xs`, `s`] mp_tac \\ gvs[] \\ `env_rel ty F acc env1 env2` by fs [env_rel_def] \\ gvs [] \\ rpt (disch_then drule) \\ rw [] \\ gvs [AllCaseEqs(), PULL_EXISTS] - \\ `r'.refs = t'.refs` by gvs [state_rel_def] - \\ `r'.clock = t'.clock` by gvs [state_rel_def] - \\ gvs [] - \\ ( - gvs [PULL_EXISTS] - \\ last_x_assum $ qspecl_then [`[AppUnit]`, `dec_clock 1 r'`] mp_tac - \\ impl_tac - >- (imp_res_tac evaluate_clock \\ gvs [dec_clock_def]) - \\ disch_then drule \\ gvs [] - \\ `env_rel ty F acc [v] [v]` by gvs [env_rel_def] - \\ disch_then drule \\ gvs [] - \\ `state_rel (dec_clock 1 r') (dec_clock 1 t')` by - gvs [state_rel_def, dec_clock_def] - \\ disch_then drule \\ gvs [] - \\ `ty_rel [v] [Any]` by gvs [ty_rel_def] - \\ disch_then drule \\ gvs [] \\ rw [] - \\ goal_assum drule \\ gvs [] - \\ `s''.refs = t''.refs` by gvs [state_rel_def] \\ gvs [] - \\ gvs [state_rel_def])) - \\ gvs [] + >- (imp_res_tac state_rel_do_app \\ gvs []) + >- (imp_res_tac state_rel_do_app_err \\ gvs []))*) + gvs [] \\ first_x_assum (qspecl_then [`xs`, `s`] mp_tac) \\ simp [bviTheory.exp_size_def] \\ `env_rel ty F acc env1 env2` by fs [env_rel_def] @@ -2019,6 +1999,8 @@ Proof \\ fs [bvl_to_bvi_id] \\ rw [] \\ fs [check_op_def, try_swap_def, opbinargs_def, get_bin_args_def, apply_op_def] \\ rw [] \\ metis_tac [is_rec_term_ok]) + \\ Cases_on `∃force_loc n. h = Force force_loc n` \\ gvs [] + >- cheat \\ Cases_on `∃ticks dest xs hdl. h = Call ticks dest xs hdl` \\ fs [] \\ rveq >- (simp [scan_expr_def, evaluate_def] diff --git a/compiler/backend/proofs/clos_to_bvlProofScript.sml b/compiler/backend/proofs/clos_to_bvlProofScript.sml index 2f3c42af9a..c18e5d4b27 100644 --- a/compiler/backend/proofs/clos_to_bvlProofScript.sml +++ b/compiler/backend/proofs/clos_to_bvlProofScript.sml @@ -3997,7 +3997,150 @@ Proof \\ last_x_assum assume_tac \\ gvs [closSemTheory.evaluate_def, compile_exps_def] \\ pairarg_tac \\ gvs [evaluate_def] - \\ Cases_on ‘evaluate (xs,env,s)’ \\ fs [] + \\ gvs [AllCaseEqs(), PULL_EXISTS] + >- ( + first_x_assum drule_all \\ rw [] + \\ rpt (goal_assum $ drule_at Any \\ gvs []) + \\ `LENGTH vs = 1` + by gvs [oneline closSemTheory.dest_thunk_def, AllCaseEqs()] + \\ Cases_on `vs` \\ gvs [] + \\ imp_res_tac evaluate_const + \\ drule (GEN_ALL rel_dest_thunk) \\ simp [] + \\ disch_then drule_all \\ rw [] + \\ goal_assum drule \\ gvs []) + >- ( + first_x_assum drule_all \\ rw [] + \\ rpt (goal_assum $ drule_at Any \\ gvs []) + \\ `LENGTH vs = 1` + by gvs [oneline closSemTheory.dest_thunk_def, AllCaseEqs()] + \\ Cases_on `vs` \\ gvs [] + \\ imp_res_tac evaluate_const + \\ drule (GEN_ALL rel_dest_thunk) \\ simp [] + \\ disch_then drule_all \\ rw [] + \\ goal_assum drule \\ gvs []) + >- ( + first_x_assum drule_all \\ rw [] + \\ `LENGTH vs = 1` + by gvs [oneline closSemTheory.dest_thunk_def, AllCaseEqs()] + \\ Cases_on `vs` \\ gvs [] + \\ imp_res_tac evaluate_const + \\ drule (GEN_ALL rel_dest_thunk) \\ simp [] + \\ disch_then drule_all \\ rw [] + \\ gvs [closSemTheory.dec_clock_def] + \\ first_x_assum $ drule_at (Pat `state_rel _ _ _`) + \\ simp [AppUnit_def, compile_exps_def] + \\ disch_then $ qspecl_then [`aux1`, `[r2]`] mp_tac \\ gvs [] + \\ impl_tac + >- ( + gvs [closSemTheory.dec_clock_def] \\ rw [] + >- ( + drule_all (GEN_ALL compile_exps_IMP_code_installed) \\ rw [] + \\ drule evaluate_mono \\ rw [] + \\ gvs [code_installed_def, subspt_def, EVERY_EL] \\ rw [] + \\ pairarg_tac \\ gvs [] + \\ first_x_assum drule \\ rw [] + \\ gvs [domain_lookup]) + >- gvs [env_rel_def]) + \\ rw [] \\ gvs [] + \\ qpat_x_assum `evaluate _ = (Rval [y],_)` assume_tac + \\ drule_then (qspec_then `ck'` assume_tac) evaluate_add_clock + \\ gvs [inc_clock_def] + \\ qexists `ck + ck'` \\ gvs [PULL_EXISTS] + \\ pop_assum kall_tac + \\ gvs [find_code_def] + \\ drule bvlPropsTheory.evaluate_mono + \\ simp [subspt_lookup] + \\ disch_then drule \\ strip_tac \\ simp [dec_clock_def] + \\ qpat_x_assum `update_thunk _ _ _ = SOME _` mp_tac + \\ simp [oneline update_thunk_def, AllCaseEqs()] \\ rw [] + \\ gvs [store_thunk_def, AllCaseEqs(), v_rel_SIMP, PULL_EXISTS] + \\ drule_at (Pat `FLOOKUP _ _ = SOME _`) state_rel_UPDATE_REF + \\ disch_then drule \\ gvs [] + \\ `FLOOKUP f2' ptr = SOME r2'` by metis_tac [FLOOKUP_SUBMAP] + \\ disch_then drule \\ gvs [] + \\ `ref_rel (v_rel s.max_app f2' t2'.refs t2'.code) + (Thunk Evaluated v'') (Thunk Evaluated y')` by gvs [ref_rel_def] + \\ disch_then drule \\ gvs [] \\ rw [] + \\ goal_assum $ drule_at (Pat `state_rel _ _ _`) \\ gvs [] + \\ qexists `y'` \\ gvs [] \\ rw [] + >- ( + qpat_x_assum `evaluate _ = (Rval [y'],_)` mp_tac + \\ simp [clos_tag_shift_def, mk_cl_call_def, + generic_app_fn_location_def, evaluate_def, do_app_def, + AllCaseEqs(), PULL_EXISTS, dec_clock_def] \\ rw [] + \\ gvs [find_code_def, AllCaseEqs()] + \\ ( + simp [force_thunk_code_def, evaluate_def, do_app_def, EL_APPEND, + find_code_def, AllCaseEqs(), PULL_EXISTS, dec_clock_def] + \\ rw [] \\ gvs [] + \\ drule_then drule (GEN_ALL state_rel_refs_lookup) \\ rw [] + \\ metis_tac [])) + >- ( + irule v_rel_UPDATE_REF \\ gvs [TO_FLOOKUP] + \\ first_x_assum drule \\ rw [SF SFY_ss]) + >- metis_tac [SUBMAP_TRANS] + >- ( + `r2' ∈ (FRANGE f2')` by ( + gvs [TO_FLOOKUP] \\ first_x_assum drule \\ rw [SF SFY_ss]) + \\ rw [FDIFF_FUPDATE] + \\ metis_tac [SUBMAP_TRANS])) + >- ( + first_x_assum drule_all \\ rw [] + \\ `LENGTH vs = 1` + by gvs [oneline closSemTheory.dest_thunk_def, AllCaseEqs()] + \\ Cases_on `vs` \\ gvs [] + \\ imp_res_tac evaluate_const + \\ drule (GEN_ALL rel_dest_thunk) \\ simp [] + \\ disch_then drule_all \\ rw [] + \\ gvs [closSemTheory.dec_clock_def] + \\ first_x_assum $ drule_at (Pat `state_rel _ _ _`) + \\ simp [AppUnit_def, compile_exps_def] + \\ disch_then $ qspecl_then [`aux1`, `[r2]`] mp_tac \\ gvs [] + \\ impl_tac + >- ( + gvs [closSemTheory.dec_clock_def] \\ rw [] + >- ( + drule_all (GEN_ALL compile_exps_IMP_code_installed) \\ rw [] + \\ drule evaluate_mono \\ rw [] + \\ gvs [code_installed_def, subspt_def, EVERY_EL] \\ rw [] + \\ pairarg_tac \\ gvs [] + \\ first_x_assum drule \\ rw [] + \\ gvs [domain_lookup]) + >- gvs [env_rel_def]) + \\ rw [] \\ gvs [] + \\ qpat_x_assum `evaluate _ = (Rval [y],_)` assume_tac + \\ drule_then (qspec_then `ck'` assume_tac) evaluate_add_clock + \\ gvs [inc_clock_def] + \\ qexists `ck + ck'` \\ gvs [PULL_EXISTS] + \\ pop_assum kall_tac + \\ gvs [find_code_def] + \\ drule bvlPropsTheory.evaluate_mono + \\ simp [subspt_lookup] + \\ disch_then drule \\ strip_tac \\ simp [dec_clock_def] + \\ goal_assum $ drule_at (Pat `state_rel _ _ _`) \\ gvs [] + \\ qexists `e'` \\ gvs [] \\ rw [] + >- ( + `e' ≠ Rabort Rtype_error` by (Cases_on `e` \\ gvs []) \\ gvs [] + \\ qpat_x_assum `evaluate _ = (Rerr e',_)` mp_tac + \\ simp [clos_tag_shift_def, mk_cl_call_def, + generic_app_fn_location_def, evaluate_def, do_app_def, + find_code_def] + \\ rpt (PURE_CASE_TAC \\ gvs []) + \\ simp [force_thunk_code_def, evaluate_def, do_app_def, + find_code_def]) + >- metis_tac [SUBMAP_TRANS] + >- metis_tac [SUBMAP_TRANS]) + >- ( + first_x_assum drule_all \\ rw [] + \\ rpt (goal_assum $ drule_at Any \\ gvs []) + \\ `LENGTH vs = 1` + by gvs [oneline closSemTheory.dest_thunk_def, AllCaseEqs()] + \\ Cases_on `vs` \\ gvs [] + \\ imp_res_tac evaluate_const + \\ drule (GEN_ALL rel_dest_thunk) \\ simp [] + \\ disch_then drule_all \\ rw [] + \\ goal_assum drule \\ gvs []) + (*\\ Cases_on ‘evaluate (xs,env,s)’ \\ fs [] \\ Cases_on ‘q = Rerr (Rabort Rtype_error)’ \\ fs [] \\ first_x_assum drule_all \\ strip_tac @@ -4026,7 +4169,7 @@ Proof \\ drule bvlPropsTheory.evaluate_mono \\ simp [subspt_lookup] \\ disch_then drule \\ strip_tac \\ simp [dec_clock_def] - \\ cheat (* + \\ cheat*) (* \\ gvs [AllCaseEqs(), PULL_EXISTS] >- ( first_x_assum drule_all \\ rw [] \\ gvs [] From 7e9ea7c9a8b92755b269a53ded1f5045a05065f5 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Fri, 15 Aug 2025 08:57:04 +0300 Subject: [PATCH 050/112] Cleanup `Force` case in `clos_to_bvlProof` --- .../backend/proofs/clos_to_bvlProofScript.sml | 334 ++++-------------- 1 file changed, 68 insertions(+), 266 deletions(-) diff --git a/compiler/backend/proofs/clos_to_bvlProofScript.sml b/compiler/backend/proofs/clos_to_bvlProofScript.sml index c18e5d4b27..126d0f1836 100644 --- a/compiler/backend/proofs/clos_to_bvlProofScript.sml +++ b/compiler/backend/proofs/clos_to_bvlProofScript.sml @@ -3997,150 +3997,7 @@ Proof \\ last_x_assum assume_tac \\ gvs [closSemTheory.evaluate_def, compile_exps_def] \\ pairarg_tac \\ gvs [evaluate_def] - \\ gvs [AllCaseEqs(), PULL_EXISTS] - >- ( - first_x_assum drule_all \\ rw [] - \\ rpt (goal_assum $ drule_at Any \\ gvs []) - \\ `LENGTH vs = 1` - by gvs [oneline closSemTheory.dest_thunk_def, AllCaseEqs()] - \\ Cases_on `vs` \\ gvs [] - \\ imp_res_tac evaluate_const - \\ drule (GEN_ALL rel_dest_thunk) \\ simp [] - \\ disch_then drule_all \\ rw [] - \\ goal_assum drule \\ gvs []) - >- ( - first_x_assum drule_all \\ rw [] - \\ rpt (goal_assum $ drule_at Any \\ gvs []) - \\ `LENGTH vs = 1` - by gvs [oneline closSemTheory.dest_thunk_def, AllCaseEqs()] - \\ Cases_on `vs` \\ gvs [] - \\ imp_res_tac evaluate_const - \\ drule (GEN_ALL rel_dest_thunk) \\ simp [] - \\ disch_then drule_all \\ rw [] - \\ goal_assum drule \\ gvs []) - >- ( - first_x_assum drule_all \\ rw [] - \\ `LENGTH vs = 1` - by gvs [oneline closSemTheory.dest_thunk_def, AllCaseEqs()] - \\ Cases_on `vs` \\ gvs [] - \\ imp_res_tac evaluate_const - \\ drule (GEN_ALL rel_dest_thunk) \\ simp [] - \\ disch_then drule_all \\ rw [] - \\ gvs [closSemTheory.dec_clock_def] - \\ first_x_assum $ drule_at (Pat `state_rel _ _ _`) - \\ simp [AppUnit_def, compile_exps_def] - \\ disch_then $ qspecl_then [`aux1`, `[r2]`] mp_tac \\ gvs [] - \\ impl_tac - >- ( - gvs [closSemTheory.dec_clock_def] \\ rw [] - >- ( - drule_all (GEN_ALL compile_exps_IMP_code_installed) \\ rw [] - \\ drule evaluate_mono \\ rw [] - \\ gvs [code_installed_def, subspt_def, EVERY_EL] \\ rw [] - \\ pairarg_tac \\ gvs [] - \\ first_x_assum drule \\ rw [] - \\ gvs [domain_lookup]) - >- gvs [env_rel_def]) - \\ rw [] \\ gvs [] - \\ qpat_x_assum `evaluate _ = (Rval [y],_)` assume_tac - \\ drule_then (qspec_then `ck'` assume_tac) evaluate_add_clock - \\ gvs [inc_clock_def] - \\ qexists `ck + ck'` \\ gvs [PULL_EXISTS] - \\ pop_assum kall_tac - \\ gvs [find_code_def] - \\ drule bvlPropsTheory.evaluate_mono - \\ simp [subspt_lookup] - \\ disch_then drule \\ strip_tac \\ simp [dec_clock_def] - \\ qpat_x_assum `update_thunk _ _ _ = SOME _` mp_tac - \\ simp [oneline update_thunk_def, AllCaseEqs()] \\ rw [] - \\ gvs [store_thunk_def, AllCaseEqs(), v_rel_SIMP, PULL_EXISTS] - \\ drule_at (Pat `FLOOKUP _ _ = SOME _`) state_rel_UPDATE_REF - \\ disch_then drule \\ gvs [] - \\ `FLOOKUP f2' ptr = SOME r2'` by metis_tac [FLOOKUP_SUBMAP] - \\ disch_then drule \\ gvs [] - \\ `ref_rel (v_rel s.max_app f2' t2'.refs t2'.code) - (Thunk Evaluated v'') (Thunk Evaluated y')` by gvs [ref_rel_def] - \\ disch_then drule \\ gvs [] \\ rw [] - \\ goal_assum $ drule_at (Pat `state_rel _ _ _`) \\ gvs [] - \\ qexists `y'` \\ gvs [] \\ rw [] - >- ( - qpat_x_assum `evaluate _ = (Rval [y'],_)` mp_tac - \\ simp [clos_tag_shift_def, mk_cl_call_def, - generic_app_fn_location_def, evaluate_def, do_app_def, - AllCaseEqs(), PULL_EXISTS, dec_clock_def] \\ rw [] - \\ gvs [find_code_def, AllCaseEqs()] - \\ ( - simp [force_thunk_code_def, evaluate_def, do_app_def, EL_APPEND, - find_code_def, AllCaseEqs(), PULL_EXISTS, dec_clock_def] - \\ rw [] \\ gvs [] - \\ drule_then drule (GEN_ALL state_rel_refs_lookup) \\ rw [] - \\ metis_tac [])) - >- ( - irule v_rel_UPDATE_REF \\ gvs [TO_FLOOKUP] - \\ first_x_assum drule \\ rw [SF SFY_ss]) - >- metis_tac [SUBMAP_TRANS] - >- ( - `r2' ∈ (FRANGE f2')` by ( - gvs [TO_FLOOKUP] \\ first_x_assum drule \\ rw [SF SFY_ss]) - \\ rw [FDIFF_FUPDATE] - \\ metis_tac [SUBMAP_TRANS])) - >- ( - first_x_assum drule_all \\ rw [] - \\ `LENGTH vs = 1` - by gvs [oneline closSemTheory.dest_thunk_def, AllCaseEqs()] - \\ Cases_on `vs` \\ gvs [] - \\ imp_res_tac evaluate_const - \\ drule (GEN_ALL rel_dest_thunk) \\ simp [] - \\ disch_then drule_all \\ rw [] - \\ gvs [closSemTheory.dec_clock_def] - \\ first_x_assum $ drule_at (Pat `state_rel _ _ _`) - \\ simp [AppUnit_def, compile_exps_def] - \\ disch_then $ qspecl_then [`aux1`, `[r2]`] mp_tac \\ gvs [] - \\ impl_tac - >- ( - gvs [closSemTheory.dec_clock_def] \\ rw [] - >- ( - drule_all (GEN_ALL compile_exps_IMP_code_installed) \\ rw [] - \\ drule evaluate_mono \\ rw [] - \\ gvs [code_installed_def, subspt_def, EVERY_EL] \\ rw [] - \\ pairarg_tac \\ gvs [] - \\ first_x_assum drule \\ rw [] - \\ gvs [domain_lookup]) - >- gvs [env_rel_def]) - \\ rw [] \\ gvs [] - \\ qpat_x_assum `evaluate _ = (Rval [y],_)` assume_tac - \\ drule_then (qspec_then `ck'` assume_tac) evaluate_add_clock - \\ gvs [inc_clock_def] - \\ qexists `ck + ck'` \\ gvs [PULL_EXISTS] - \\ pop_assum kall_tac - \\ gvs [find_code_def] - \\ drule bvlPropsTheory.evaluate_mono - \\ simp [subspt_lookup] - \\ disch_then drule \\ strip_tac \\ simp [dec_clock_def] - \\ goal_assum $ drule_at (Pat `state_rel _ _ _`) \\ gvs [] - \\ qexists `e'` \\ gvs [] \\ rw [] - >- ( - `e' ≠ Rabort Rtype_error` by (Cases_on `e` \\ gvs []) \\ gvs [] - \\ qpat_x_assum `evaluate _ = (Rerr e',_)` mp_tac - \\ simp [clos_tag_shift_def, mk_cl_call_def, - generic_app_fn_location_def, evaluate_def, do_app_def, - find_code_def] - \\ rpt (PURE_CASE_TAC \\ gvs []) - \\ simp [force_thunk_code_def, evaluate_def, do_app_def, - find_code_def]) - >- metis_tac [SUBMAP_TRANS] - >- metis_tac [SUBMAP_TRANS]) - >- ( - first_x_assum drule_all \\ rw [] - \\ rpt (goal_assum $ drule_at Any \\ gvs []) - \\ `LENGTH vs = 1` - by gvs [oneline closSemTheory.dest_thunk_def, AllCaseEqs()] - \\ Cases_on `vs` \\ gvs [] - \\ imp_res_tac evaluate_const - \\ drule (GEN_ALL rel_dest_thunk) \\ simp [] - \\ disch_then drule_all \\ rw [] - \\ goal_assum drule \\ gvs []) - (*\\ Cases_on ‘evaluate (xs,env,s)’ \\ fs [] + \\ Cases_on ‘evaluate (xs,env,s)’ \\ fs [] \\ Cases_on ‘q = Rerr (Rabort Rtype_error)’ \\ fs [] \\ first_x_assum drule_all \\ strip_tac @@ -4153,7 +4010,8 @@ Proof \\ qrefine ‘ck + ck2’ \\ gvs [] \\ drule evaluate_add_clock \\ simp [inc_clock_def] \\ disch_then kall_tac - \\ ‘LENGTH a = 1’ by gvs [oneline closSemTheory.dest_thunk_def,AllCaseEqs()] + \\ ‘LENGTH a = 1’ by + gvs [oneline closSemTheory.dest_thunk_def,AllCaseEqs()] \\ gvs [LENGTH_EQ_NUM_compute] \\ drule_at (Pos last) rel_dest_thunk \\ imp_res_tac evaluate_const \\ gvs [] @@ -4169,132 +4027,76 @@ Proof \\ drule bvlPropsTheory.evaluate_mono \\ simp [subspt_lookup] \\ disch_then drule \\ strip_tac \\ simp [dec_clock_def] - \\ cheat*) (* - \\ gvs [AllCaseEqs(), PULL_EXISTS] + \\ gvs [closSemTheory.dec_clock_def] + \\ first_x_assum $ drule_at (Pat ‘state_rel _ _ _’) + \\ Cases_on + ‘evaluate ([AppUnit (Var None 0)],[v],r with clock := t2.clock − 1)’ + \\ gvs [] + \\ Cases_on ‘q = Rerr (Rabort Rtype_error)’ \\ gvs [] + \\ gvs [AppUnit_def] \\ simp [compile_exps_def] + \\ disch_then $ qspecl_then [‘aux1’, ‘[r2]’] mp_tac \\ gvs [] + \\ impl_tac >- ( - first_x_assum drule_all \\ rw [] \\ gvs [] - \\ goal_assum drule \\ gvs [] - \\ imp_res_tac evaluate_const \\ gvs [] - \\ drule (GEN_ALL rel_dest_thunk) \\ simp [] - \\ disch_then drule \\ rw [] \\ gvs [] - \\ goal_assum drule \\ gvs []) - >- ( - first_x_assum drule_all \\ rw [] \\ gvs [] - \\ goal_assum drule \\ gvs [] - \\ imp_res_tac evaluate_const \\ gvs [] - \\ drule (GEN_ALL rel_dest_thunk) \\ simp [] - \\ disch_then drule \\ rw [] \\ gvs [] - \\ goal_assum drule \\ gvs []) - >- ( - first_x_assum drule_all \\ rw [] \\ gvs [] - \\ `∀ck'. evaluate (c1,env'',t1 with clock := ck' + ck + s.clock) = - (Rval v', t2 with clock := t2.clock + ck')` by ( - rw [] \\ drule evaluate_add_clock \\ rw [inc_clock_def]) \\ gvs [] - \\ qrefine `ck + ck'` \\ gvs [] - \\ imp_res_tac evaluate_const \\ gvs [] - \\ drule (GEN_ALL rel_dest_thunk) \\ simp [] - \\ disch_then drule \\ rw [] \\ gvs [PULL_EXISTS] - \\ `state_rel f2 (dec_clock 1 s') (dec_clock 1 t2)` by ( - gvs [state_rel_def, closSemTheory.dec_clock_def, dec_clock_def] - \\ rw [] \\ first_x_assum drule \\ rw []) \\ gvs [] - \\ first_x_assum $ drule_at (Pat `state_rel _ _`) - \\ simp [closSemTheory.AppUnit_def, compile_exps_def] - \\ disch_then $ qspecl_then [`aux1`, `[r2]`] mp_tac - \\ impl_tac >- ( - gvs [closSemTheory.dec_clock_def] \\ rw [] - >- ( - drule_all (GEN_ALL compile_exps_IMP_code_installed) \\ rw [] - \\ drule evaluate_mono \\ rw [] - \\ gvs [code_installed_def, subspt_def, EVERY_EL] \\ rw [] - \\ pairarg_tac \\ gvs [] - \\ first_x_assum drule \\ rw [] - \\ gvs [domain_lookup]) - >- gvs [env_rel_def]) - \\ rw [] \\ simp [] - \\ gvs [closSemTheory.dec_clock_def, dec_clock_def] - \\ qrefinel [`_`, `f2'`, `v''`, `t2'`] \\ rw [GSYM PULL_EXISTS] - >- ( - gvs [AppUnit_def] - \\ gvs [evaluate_def, clos_tag_shift_def, mk_cl_call_def, do_app_def, - do_int_app_def] - \\ Cases_on `r2` - \\ gvs [AllCaseEqs(), PULL_EXISTS, evaluate_def, - generic_app_fn_location_def] - \\ goal_assum drule \\ gvs []) - \\ gvs [oneline closSemTheory.update_thunk_def, oneline update_thunk_def, - AllCaseEqs(), PULL_EXISTS] - \\ qpat_x_assum `v_rel _ _ _ _ _ y` mp_tac - \\ reverse $ rw [Once v_rel_cases] - >- gvs [add_args_F] - >- gvs [Once cl_rel_cases] - \\ gvs [closSemTheory.store_thunk_def, store_thunk_def, AllCaseEqs(), - PULL_EXISTS] - \\ gvs [dest_thunk_def, closSemTheory.dest_thunk_def, AllCaseEqs()] - \\ reverse $ rw [GSYM PULL_EXISTS] - >- ( - `r2' ∈ (FRANGE f2')` by ( - gvs [TO_FLOOKUP] \\ first_x_assum drule \\ rw [SF SFY_ss]) - \\ gvs [FDIFF_FUPDATE] \\ rw [] - \\ imp_res_tac SUBMAP_TRANS) - >- imp_res_tac SUBMAP_TRANS - >- ( - irule state_rel_UPDATE_REF \\ rw [] - \\ gvs [FLOOKUP_DEF, SUBMAP_DEF]) + gvs [closSemTheory.dec_clock_def] \\ rw [] >- ( - irule v_rel_UPDATE_REF \\ rw [] - \\ gvs [FLOOKUP_DEF] - \\ irule (iffRL IN_FRANGE) - \\ qexists `ptr` \\ gvs [SUBMAP_DEF]) - >- ( - drule_then drule (GEN_ALL state_rel_refs_lookup) \\ rw [] - \\ gvs [FLOOKUP_DEF, SUBMAP_DEF]) - \\ gvs [oneline closSemTheory.dest_thunk_def, oneline dest_thunk_def, - AllCaseEqs(), PULL_EXISTS] - \\ qpat_x_assum `v_rel _ _ _ _ _ y'` mp_tac - \\ rw [Once v_rel_cases] - \\ drule_all state_rel_refs_lookup \\ rw [] \\ gvs []) + drule_all (GEN_ALL compile_exps_IMP_code_installed) \\ rw [] + \\ drule evaluate_mono \\ rw [] + \\ gvs [code_installed_def, subspt_def, EVERY_EL] \\ rw [] + \\ pairarg_tac \\ gvs [] + \\ first_x_assum drule \\ rw [] + \\ gvs [domain_lookup]) + >- gvs [env_rel_def]) + \\ rw [] \\ gvs [] + \\ qexists ‘ck'’ \\ gvs [PULL_EXISTS] + \\ reverse $ Cases_on ‘q’ \\ gvs [PULL_EXISTS] >- ( - first_x_assum drule_all \\ rw [] \\ gvs [] - \\ `∀ck'. evaluate (c1,env'',t1 with clock := ck' + ck + s.clock) = - (Rval v', t2 with clock := t2.clock + ck')` by ( - rw [] \\ drule evaluate_add_clock \\ rw [inc_clock_def]) \\ gvs [] - \\ qrefine `ck + ck'` \\ gvs [] - \\ imp_res_tac evaluate_const \\ gvs [] - \\ drule (GEN_ALL rel_dest_thunk) \\ simp [] - \\ disch_then drule \\ rw [] \\ gvs [PULL_EXISTS] - \\ `state_rel f2 (dec_clock 1 s') (dec_clock 1 t2)` by ( - gvs [state_rel_def, closSemTheory.dec_clock_def, dec_clock_def] - \\ rw [] \\ first_x_assum drule \\ rw []) \\ gvs [] - \\ first_x_assum $ drule_at (Pat `state_rel _ _`) - \\ simp [closSemTheory.AppUnit_def, compile_exps_def] - \\ disch_then $ qspecl_then [`aux1`, `[r2]`] mp_tac - \\ impl_tac >- ( - gvs [closSemTheory.dec_clock_def] \\ rw [] - >- ( - drule_all (GEN_ALL compile_exps_IMP_code_installed) \\ rw [] - \\ drule evaluate_mono \\ rw [] - \\ gvs [code_installed_def, subspt_def, EVERY_EL] \\ rw [] - \\ pairarg_tac \\ gvs [] - \\ first_x_assum drule \\ rw [] - \\ gvs [domain_lookup]) - >- gvs [env_rel_def]) - \\ rw [] \\ simp [] - \\ gvs [closSemTheory.dec_clock_def, dec_clock_def] - \\ rpt (goal_assum $ drule_at Any \\ gvs []) - \\ qrefinel [`_`, `Rerr e'`, `t2'`] \\ rw [GSYM PULL_EXISTS] + goal_assum $ drule_at (Pat ‘state_rel _ _ _’) \\ gvs [] + \\ qexists ‘e'’ \\ gvs [] \\ rw [] >- ( - gvs [AppUnit_def] - \\ simp [do_app_def, do_int_app_def, evaluate_def] - \\ qexists `ck'` \\ gvs [] - \\ gvs [evaluate_def, mk_cl_call_def, generic_app_fn_location_def, - do_app_def, clos_tag_shift_def, find_code_def] - \\ rpt (PURE_CASE_TAC \\ gvs []) - \\ gvs [AllCaseEqs()]) - \\ imp_res_tac SUBMAP_TRANS) + ‘e' ≠ Rabort Rtype_error’ by (Cases_on ‘e’ \\ gvs []) \\ gvs [] + \\ qpat_x_assum ‘evaluate _ = (Rerr e',_)’ mp_tac + \\ simp [clos_tag_shift_def, mk_cl_call_def, + generic_app_fn_location_def, evaluate_def, do_app_def, + find_code_def] + \\ rpt (PURE_CASE_TAC \\ gvs []) + \\ simp [force_thunk_code_def, evaluate_def, do_app_def, + find_code_def]) + \\ metis_tac [SUBMAP_TRANS]) + \\ Cases_on ‘update_thunk [h] r'.refs a’ \\ gvs [PULL_EXISTS] + \\ pop_assum mp_tac + \\ simp [oneline update_thunk_def, AllCaseEqs()] \\ rw [] + \\ gvs [store_thunk_def, AllCaseEqs(), v_rel_SIMP, PULL_EXISTS] + \\ drule_at (Pat ‘FLOOKUP _ _ = SOME _’) state_rel_UPDATE_REF + \\ disch_then drule \\ gvs [] + \\ ‘FLOOKUP f2' ptr = SOME r2'’ by metis_tac [FLOOKUP_SUBMAP] + \\ disch_then drule \\ gvs [] + \\ imp_res_tac evaluate_const \\ gvs [] + \\ `ref_rel (v_rel s.max_app f2' t2'.refs t2'.code) + (Thunk Evaluated v'') (Thunk Evaluated y')` by gvs [ref_rel_def] + \\ disch_then drule \\ gvs [] \\ rw [] + \\ goal_assum $ drule_at (Pat ‘state_rel _ _ _’) \\ gvs [] + \\ qexists ‘y'’ \\ gvs [] \\ rw [] + >- ( + qpat_x_assum ‘evaluate _ = (Rval [y'],_)’ mp_tac + \\ simp [clos_tag_shift_def, mk_cl_call_def, + generic_app_fn_location_def, evaluate_def, do_app_def, + AllCaseEqs(), PULL_EXISTS, dec_clock_def] \\ rw [] + \\ gvs [find_code_def, AllCaseEqs()] + \\ ( + simp [force_thunk_code_def, evaluate_def, do_app_def, EL_APPEND, + find_code_def, AllCaseEqs(), PULL_EXISTS, dec_clock_def] + \\ rw [] \\ gvs [] + \\ drule_then drule (GEN_ALL state_rel_refs_lookup) \\ rw [] + \\ metis_tac [])) + >- ( + irule v_rel_UPDATE_REF \\ gvs [TO_FLOOKUP] + \\ first_x_assum drule \\ rw [SF SFY_ss]) + >- metis_tac [SUBMAP_TRANS] >- ( - first_x_assum drule_all \\ rw [] \\ gvs [] - \\ goal_assum drule \\ rw [PULL_EXISTS] - \\ goal_assum drule \\ gvs []) *) ) + ‘r2' ∈ (FRANGE f2')’ by ( + gvs [TO_FLOOKUP] \\ first_x_assum drule \\ rw [SF SFY_ss]) + \\ rw [FDIFF_FUPDATE] + \\ metis_tac [SUBMAP_TRANS])) \\ srw_tac[][] \\ full_simp_tac(srw_ss())[cEval_def,compile_exps_def] \\ SRW_TAC [] [bEval_def] \\ `?p. evaluate (xs,env,s) = p` by full_simp_tac(srw_ss())[] \\ PairCases_on `p` \\ full_simp_tac(srw_ss())[] From 7095e5e7100f5ff0bb958aa759d091f4aa8f677c Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Sat, 16 Aug 2025 13:12:07 +0300 Subject: [PATCH 051/112] Progress in `backend/passes/proofs`, `bvl_to_bviProof` done --- compiler/backend/bvl_to_bviScript.sml | 5 +- .../backend/proofs/bvl_constProofScript.sml | 16 +- .../backend/proofs/bvl_handleProofScript.sml | 11 +- .../backend/proofs/bvl_inlineProofScript.sml | 101 +++-- .../backend/proofs/bvl_to_bviProofScript.sml | 361 +++++------------- compiler/backend/semantics/bviPropsScript.sml | 1 + 6 files changed, 161 insertions(+), 334 deletions(-) diff --git a/compiler/backend/bvl_to_bviScript.sml b/compiler/backend/bvl_to_bviScript.sml index 2e03d04683..134ad6386e 100644 --- a/compiler/backend/bvl_to_bviScript.sml +++ b/compiler/backend/bvl_to_bviScript.sml @@ -358,7 +358,8 @@ Definition compile_exps_def: (compile_exps n [Tick x1] = let (c1,aux1,n1) = compile_exps n [x1] in ([Tick (HD c1)], aux1, n1)) /\ - (compile_exps n [Force loc v] = ([Force loc v], Nil, n)) /\ + (compile_exps n [Force loc v] = + ([Force (num_stubs + nss * loc) v], Nil, n)) /\ (compile_exps n [Op op xs] = let (c1,aux1,n1) = compile_exps n xs in ([compile_op op c1],aux1,n1)) /\ @@ -411,7 +412,7 @@ Definition compile_exps_sing_def: let (c1,aux1,n1) = compile_exps_sing n x1 in (Tick c1, aux1, n1)) /\ (compile_exps_sing n (Force loc v) = - (Force loc v, Nil, n)) /\ + (Force (num_stubs + nss * loc) v, Nil, n)) /\ (compile_exps_sing n (Op op xs) = let (c1,aux1,n1) = compile_exps_list n xs in (compile_op op c1,aux1,n1)) /\ diff --git a/compiler/backend/proofs/bvl_constProofScript.sml b/compiler/backend/proofs/bvl_constProofScript.sml index b944063337..dc3e156e8b 100644 --- a/compiler/backend/proofs/bvl_constProofScript.sml +++ b/compiler/backend/proofs/bvl_constProofScript.sml @@ -182,11 +182,13 @@ Proof fs [dest_simple_eq, case_op_const_eq] \\ simp [evaluate_def, do_app_def,oneline do_int_app_def] \\ fsrw_tac [DNF_ss] [case_eq_thms] \\ - rw [REVERSE_DEF] \\ - imp_res_tac evaluate_SING \\ - fs [] \\ rveq \\ - gvs [oneline dest_thunk_def, AllCaseEqs()] \\ - intLib.COOPER_TAC) + rw [REVERSE_DEF] + \\ ( + imp_res_tac evaluate_SING \\ + fs [] \\ rveq \\ + intLib.COOPER_TAC + ORELSE metis_tac [intLib.COOPER_PROVE + ``!(a : int) b. 0 ≤ a ∧ a < &b ⇒ Num a < b``])) \\ fs [] \\ every_case_tac \\ fs [] \\ fs [dest_simple_eq] \\ rveq @@ -218,7 +220,6 @@ Proof \\ rw [] \\ gvs [] \\ eq_tac \\ rw [] QED - Theorem SmartOp_thm: evaluate ([Op op xs],env,s) = (res,s2) /\ res ≠ Rerr (Rabort Rtype_error) ==> @@ -294,8 +295,7 @@ Proof \\ res_tac \\ rw [] \\ Cases_on `e` \\ fs [] \\ rw [] \\ fs [] \\ first_x_assum match_mp_tac \\ fs [env_rel_def]) - \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs [] - >- (gvs [AllCaseEqs()] \\ irule SmartOp_thm \\ rw [evaluate_def]) + >>~- ([`dest_thunk`], cheat) \\ TRY (match_mp_tac SmartOp_thm) \\ fs [evaluate_def] \\ every_case_tac \\ fs [] \\ rw [] \\ fs [] \\ res_tac \\ fs [] \\ rw [] \\ fs [] \\ rw [] \\ fs [] diff --git a/compiler/backend/proofs/bvl_handleProofScript.sml b/compiler/backend/proofs/bvl_handleProofScript.sml index 82abdabdb5..d3d129af56 100644 --- a/compiler/backend/proofs/bvl_handleProofScript.sml +++ b/compiler/backend/proofs/bvl_handleProofScript.sml @@ -56,6 +56,8 @@ Proof (rpt (CASE_TAC \\ fs []) \\ first_x_assum (qspec_then ‘a'::xs’ mp_tac) \\ imp_res_tac evaluate_IMP_LENGTH \\ fs [ADD1]) + >- + (rw [] \\ gvs [EL_APPEND]) \\ once_rewrite_tac [evaluate_CONS] \\ fs [] QED @@ -180,6 +182,7 @@ Definition handle_ok_def: EVERY isVar xs /\ bVarBound (LENGTH xs) [b] /\ handle_ok [b] /\ handle_ok [x2] | _ => F) /\ + (handle_ok [Force loc n] <=> T) ∧ (handle_ok [Call ticks dest xs] <=> handle_ok xs) Termination WF_REL_TAC `measure (exp1_size)` @@ -452,6 +455,12 @@ Theorem compile_correct = Q.prove(` \\ imp_res_tac do_app_err \\ fs [] \\ res_tac \\ fs []) THEN1 (* Tick *) (Cases_on `s.clock = 0` \\ fs [] \\ rw [evaluate_def] \\ res_tac \\ fs []) + THEN1 (* Force *) + (rw [] \\ gvs [] + \\ gvs [AllCaseEqs(), evaluate_def, PULL_EXISTS] + \\ imp_res_tac env_rel_length \\ gvs [EL_APPEND] + \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS, env_rel_def, + LIST_RELi_EL_EQN]) THEN1 (* Call *) (fs [env_rel_mk_Union] \\ rpt gen_tac \\ strip_tac \\ drule (GEN_ALL OptionalLetLet_IMP) \\ strip_tac @@ -796,7 +805,7 @@ Proof \\ rveq \\ fs[NULL_EQ] \\ rw[bvl_handleTheory.OptionalLetLet_def] \\ fs[] \\ fsrw_tac[DNF_ss][SUBSET_DEF] - \\ EVAL_TAC + \\ EVAL_TAC \\ rw [] QED Triviality get_code_labels_dest_handle_Raise: diff --git a/compiler/backend/proofs/bvl_inlineProofScript.sml b/compiler/backend/proofs/bvl_inlineProofScript.sml index 2ce362485b..c5660f4035 100644 --- a/compiler/backend/proofs/bvl_inlineProofScript.sml +++ b/compiler/backend/proofs/bvl_inlineProofScript.sml @@ -213,37 +213,8 @@ Proof \\ drule evaluate_add_clock \\ fs [inc_clock_def]) THEN1 (* Op *) (fs [remove_ticks_def,evaluate_def] - \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs [] - >- ( - Cases_on `evaluate (remove_ticks xs,env,s)` \\ gvs [] - \\ reverse $ Cases_on `q` \\ gvs [] - >- ( - first_x_assum drule \\ gvs [] - \\ disch_then drule \\ strip_tac - \\ qexists `ck` \\ gvs []) - \\ first_x_assum drule \\ gvs [] - \\ disch_then drule \\ strip_tac - \\ `t'.refs = r.refs` by gvs [state_rel_def] - \\ `t'.clock = r.clock` by gvs [state_rel_def] - \\ gvs [AllCaseEqs(), PULL_EXISTS] - \\ TRY (qexists `ck` \\ gvs [] \\ NO_TAC) - \\ ( - qrefine `ck' + ck` - \\ `∀ck'. evaluate (xs,env,t with clock := ck' + ck + t.clock) = - (Rval a,t' with clock := ck' + t'.clock)` by ( - imp_res_tac evaluate_add_clock \\ gvs [inc_clock_def]) - \\ gvs [PULL_EXISTS] - \\ `evaluate (remove_ticks [AppUnit],[v],dec_clock 1 r) = - evaluate ([AppUnit],[v],dec_clock 1 r)` - by gvs [AppUnit_def, remove_ticks_def] - \\ gvs [] - \\ `(dec_clock 1 r).clock < s.clock` by ( - imp_res_tac evaluate_clock \\ gvs [dec_clock_def]) - \\ `state_rel (dec_clock 1 t') (dec_clock 1 r)` by ( - gvs [state_rel_def, dec_clock_def]) - \\ last_x_assum drule_all \\ rw [dec_clock_def] - \\ goal_assum drule \\ gvs [] - \\ gvs [state_rel_def])) + \\ Cases_on ‘op = ThunkOp ForceThunk’ \\ gvs [] + >- (gvs [AllCaseEqs(), do_app_def, PULL_EXISTS] \\ metis_tac []) \\ FULL_CASE_TAC \\ fs [] \\ first_x_assum drule \\ fs [] \\ disch_then drule \\ strip_tac @@ -257,6 +228,14 @@ Proof \\ disch_then drule \\ strip_tac \\ fs [bvlSemTheory.evaluate_def] \\ qexists_tac `ck + 1` \\ fs [dec_clock_def]) + THEN1 + (gvs [remove_ticks_def, evaluate_def, oneline dest_thunk_def, + AllCaseEqs(), PULL_EXISTS, state_rel_def, find_code_def, + lookup_map, dec_clock_def] + >- (qexistsl [‘0’, ‘t with clock := 0`] \\ gvs []) + \\ last_x_assum $ drule_at (Pat ‘evaluate _ = _’) + \\ disch_then $ qspec_then ‘t with clock := t.clock - 1’ assume_tac + \\ gvs [] \\ metis_tac []) (* Call *) \\ fs [remove_ticks_def] \\ fs [bvlSemTheory.evaluate_def] @@ -613,6 +592,7 @@ Inductive exp_rel: exp_rel cs [Tick x] [Tick y]) /\ (exp_rel cs xs ys ==> exp_rel cs [Op op xs] [Op op ys]) /\ + (exp_rel cs [Force loc n] [Force loc n]) /\ (exp_rel cs xs ys ==> exp_rel cs [Call ticks dest xs] [Call ticks dest ys]) /\ (exp_rel cs xs ys /\ lookup n cs = SOME (arity, x) /\ @@ -1006,19 +986,8 @@ Proof \\ drule subspt_exp_rel \\ disch_then drule \\ rw [] \\ pop_assum drule \\ rw [] \\ fs []) THEN1 - (Cases_on `op = ThunkOp ForceThunk` \\ gvs [] - >- ( - gvs [evaluate_def] - \\ gvs [AllCaseEqs(), PULL_EXISTS] - \\ ( - first_x_assum drule_all \\ rw [] \\ gvs [PULL_EXISTS] - \\ `s'.refs = t2.refs` by gvs [in_state_rel_def] \\ gvs [PULL_EXISTS] - \\ `s'.clock = t2.clock` by gvs [in_state_rel_def] \\ gvs [] - \\ `in_state_rel limit (dec_clock 1 s') (dec_clock 1 t2)` - by gvs [in_state_rel_def, dec_clock_def] - \\ last_x_assum drule - \\ disch_then $ qspec_then `[AppUnit]` assume_tac - \\ gvs [exp_rel_refl, in_state_rel_def])) + (Cases_on ‘op = ThunkOp ForceThunk’ \\ gvs [] + >- gvs [evaluate_def, do_app_def, AllCaseEqs()] \\ fs [case_eq_thms] \\ rveq \\ fs [] \\ first_x_assum drule \\ disch_then drule \\ strip_tac @@ -1036,6 +1005,15 @@ Proof \\ first_x_assum drule \\ disch_then drule \\ strip_tac \\ fs [evaluate_def]) + THEN1 + (gvs [AllCaseEqs(), evaluate_def, PULL_EXISTS, oneline dest_thunk_def] + >- gvs [in_state_rel_def] + >- gvs [in_state_rel_def] + \\ ‘in_state_rel limit (dec_clock 1 s) (dec_clock 1 t1)’ + by gvs [in_state_rel_def, dec_clock_def] + \\ last_x_assum drule \\ rw [] + \\ gvs [find_code_def, AllCaseEqs(), in_state_rel_def, PULL_EXISTS] + \\ last_x_assum drule \\ rw [] \\ gvs []) THEN1 (reverse (fs [case_eq_thms] \\ rveq \\ fs []) \\ first_x_assum drule @@ -1595,18 +1573,8 @@ Proof (fs [case_eq_thms] \\ rveq \\ fs [] \\ res_tac \\ fs [] \\ res_tac \\ fs []) THEN1 - (Cases_on `op = ThunkOp ForceThunk` \\ gvs [] - >- ( - gvs [AllCaseEqs(), PULL_EXISTS] - \\ ( - first_x_assum drule \\ rw [] \\ gvs [PULL_EXISTS] - \\ `s'.refs = t2.refs` by gvs [let_state_rel_def] \\ gvs [PULL_EXISTS] - \\ `s'.clock = t2.clock` by gvs [let_state_rel_def] \\ gvs [] - \\ `let_state_rel q4 l4 (dec_clock 1 s') (dec_clock 1 t2)` - by gvs [let_state_rel_def, dec_clock_def] - \\ last_x_assum drule \\ rw [AppUnit_def, let_op_def] - \\ gvs [] - \\ gvs [let_state_rel_def])) + (Cases_on ‘op = ThunkOp ForceThunk’ \\ gvs [] + >- gvs [AllCaseEqs(), PULL_EXISTS, do_app_def] \\ fs [case_eq_thms] \\ rveq \\ fs [] \\ res_tac \\ fs [] \\ res_tac \\ fs [] \\ rveq \\ fs [] @@ -1621,6 +1589,27 @@ Proof \\ fs [] \\ res_tac \\ fs [] \\ res_tac \\ fs [] \\ rveq \\ fs [] \\ qexists_tac `t2` \\ fs [] \\ fs [let_state_rel_def]) + THEN1 + (gvs [AllCaseEqs(), PULL_EXISTS] + >- gvs [let_state_rel_def] + >- gvs [let_state_rel_def] + \\ rename1 ‘let_state_rel q l s t’ + \\ ‘let_state_rel q l (dec_clock 1 s) (dec_clock 1 t)’ + by gvs [let_state_rel_def, dec_clock_def] + \\ last_x_assum drule \\ rw [] + \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ ‘FLOOKUP t.refs ptr = SOME (Thunk NotEvaluated v)’ + by gvs [let_state_rel_def] + \\ gvs [] + \\ ‘t.clock ≠ 0’ by gvs [let_state_rel_def] \\ gvs [PULL_EXISTS] + \\ goal_assum $ drule_at Any \\ gvs [] + \\ ‘find_code (SOME force_loc) [RefPtr v0 ptr; v] t.code = SOME (args, + compile_any q l (LENGTH args) (let_op_sing exp))’ + by gvs [find_code_def, AllCaseEqs(), let_state_rel_def, lookup_map, + let_opt_def] + \\ gvs [] + \\ match_mp_tac bvl_handleProofTheory.compile_any_correct \\ fs [] + \\ gvs [let_op_sing_thm]) THEN1 (fs [case_eq_thms] \\ rveq \\ fs [] \\ res_tac \\ fs [] \\ res_tac \\ fs [] \\ rveq diff --git a/compiler/backend/proofs/bvl_to_bviProofScript.sml b/compiler/backend/proofs/bvl_to_bviProofScript.sml index 6284d328eb..15fef699aa 100644 --- a/compiler/backend/proofs/bvl_to_bviProofScript.sml +++ b/compiler/backend/proofs/bvl_to_bviProofScript.sml @@ -619,133 +619,35 @@ Theorem evaluate_ok: EVERY (bv_ok t.refs) env Proof recInduct bvlSemTheory.evaluate_ind \\ rpt strip_tac - >>~ [`ForceThunk`] + >>~ [‘Force’] >- ( - Cases_on `op = ThunkOp ForceThunk` \\ gvs [] - >- ( - fs [bvlSemTheory.evaluate_def] \\ rw [] \\ fs [] - \\ fs [case_eq_thms] \\ rveq \\ fs [] - \\ `state_ok (dec_clock 1 s')` by - gvs [state_ok_def, bvlSemTheory.dec_clock_def] - \\ gvs [AllCaseEqs()] - \\ `bv_ok s'.refs v` by ( - gvs [oneline bvlSemTheory.dest_thunk_def, AllCaseEqs(), state_ok_def] - \\ rpt (first_x_assum $ qspec_then `ptr` assume_tac \\ gvs [])) - \\ gvs [oneline bvlSemTheory.update_thunk_def, AllCaseEqs(), - bvlSemTheory.store_thunk_def] - \\ qpat_x_assum `state_ok s''` mp_tac - \\ rw [state_ok_def] - >- ( - gvs [EVERY_EL] \\ rw [] - \\ first_x_assum drule \\ rw [] - \\ CASE_TAC \\ gvs [] - \\ irule bv_ok_SUBSET_IMP \\ gvs [] - \\ goal_assum $ drule_at Any \\ gvs [FLOOKUP_DEF, ABSORPTION]) - >- ( - gvs [FLOOKUP_UPDATE] \\ rw [] - >- ( - irule bv_ok_SUBSET_IMP \\ gvs [] - \\ goal_assum $ drule_at Any \\ gvs [FLOOKUP_DEF, ABSORPTION]) - \\ first_x_assum $ qspec_then `k` assume_tac \\ gvs [] - \\ rpt (CASE_TAC \\ gvs []) - >- ( - gvs [EVERY_EL] \\ rw [] - \\ first_x_assum drule \\ rw [] - \\ irule bv_ok_SUBSET_IMP \\ gvs [] - \\ goal_assum $ drule_at Any \\ gvs [FLOOKUP_DEF, ABSORPTION]) - >- ( - irule bv_ok_SUBSET_IMP \\ gvs [] - \\ goal_assum $ drule_at Any \\ gvs [FLOOKUP_DEF, ABSORPTION]))) - \\ fs[bvlSemTheory.evaluate_def] \\ rw [] \\ fs [] - \\ fs [case_eq_thms] \\ rveq \\ fs [] - \\ imp_res_tac evaluate_IMP_bv_ok \\ fs [] - \\ ( - do_app_ok - |> REWRITE_RULE [CONJ_ASSOC] - |> ONCE_REWRITE_RULE [CONJ_COMM] |> GEN_ALL |> drule) - \\ fs [EVERY_REVERSE]) + gvs [bvlSemTheory.evaluate_def, AllCaseEqs()] + \\ last_x_assum mp_tac \\ impl_tac \\ rw [] + >- gvs [state_ok_def, bvlSemTheory.dec_clock_def] + \\ gvs [find_code_def, AllCaseEqs(), EVERY_EL, state_ok_def, + oneline bvlSemTheory.dest_thunk_def, bv_ok_def, FLOOKUP_DEF] + \\ rpt (first_x_assum $ qspec_then ‘ptr’ assume_tac \\ gvs [])) >- ( - Cases_on `op = ThunkOp ForceThunk` \\ gvs [] + gvs [bvlSemTheory.evaluate_def, AllCaseEqs()] >- ( - fs [bvlSemTheory.evaluate_def] \\ rw [] \\ fs [] - \\ fs [case_eq_thms] \\ rveq \\ fs [] - \\ gvs [AllCaseEqs()] - >- ( - gvs [oneline bvlSemTheory.dest_thunk_def, AllCaseEqs()] - \\ qpat_x_assum `state_ok s'` mp_tac \\ rw [state_ok_def] - \\ pop_assum $ qspec_then `ptr` assume_tac \\ gvs []) - >- ( - `state_ok (dec_clock 1 s')` by - gvs [state_ok_def, bvlSemTheory.dec_clock_def] - \\ gvs [] - \\ `bv_ok s'.refs v` by ( - gvs [oneline bvlSemTheory.dest_thunk_def, AllCaseEqs(), state_ok_def] - \\ rpt (first_x_assum $ qspec_then `ptr` assume_tac \\ gvs [])) - \\ gvs [oneline bvlSemTheory.update_thunk_def, AllCaseEqs(), - bvlSemTheory.store_thunk_def] - \\ irule bv_ok_SUBSET_IMP \\ gvs [] - \\ goal_assum $ drule_at Any \\ gvs [FLOOKUP_DEF, ABSORPTION]) - >- ( - CASE_TAC \\ gvs [] - \\ pop_assum mp_tac \\ impl_tac - >- ( - rw [] - >- gvs [state_ok_def, bvlSemTheory.dec_clock_def] - >- ( - gvs [oneline bvlSemTheory.dest_thunk_def, AllCaseEqs(), - state_ok_def] - \\ rpt (first_x_assum $ qspec_then `ptr` assume_tac \\ gvs []))) - \\ gvs [])) - \\ fs [bvlSemTheory.evaluate_def] \\ rw [] \\ fs [] - \\ fs [case_eq_thms] \\ rveq \\ fs [] - >- ( - imp_res_tac evaluate_IMP_bv_ok \\ fs [] - \\ ( - do_app_ok - |> REWRITE_RULE [CONJ_ASSOC] - |> ONCE_REWRITE_RULE [CONJ_COMM] |> GEN_ALL |> drule) - \\ fs [EVERY_REVERSE]) + gvs [oneline bvlSemTheory.dest_thunk_def, AllCaseEqs(), state_ok_def] + \\ first_x_assum $ qspec_then ‘ptr’ assume_tac \\ gvs []) + \\ rpt (CASE_TAC \\ gvs []) >- ( - imp_res_tac evaluate_IMP_bv_ok \\ fs [] - \\ every_case_tac \\ fs [] - \\ imp_res_tac bvlPropsTheory.do_app_err \\ fs[evaluate_ok_lemma])) + pop_assum mp_tac \\ impl_tac \\ rw [] + >- gvs [state_ok_def, bvlSemTheory.dec_clock_def] + \\ gvs [find_code_def, AllCaseEqs(), EVERY_EL, state_ok_def, + oneline bvlSemTheory.dest_thunk_def, bv_ok_def, FLOOKUP_DEF] + \\ rpt (first_x_assum $ qspec_then ‘ptr’ assume_tac \\ gvs [])) + \\ qpat_x_assum ‘_ ⇒ _’ mp_tac \\ impl_tac \\ rw [] + >- gvs [state_ok_def, bvlSemTheory.dec_clock_def] + \\ gvs [find_code_def, AllCaseEqs(), EVERY_EL, state_ok_def, + oneline bvlSemTheory.dest_thunk_def, bv_ok_def, FLOOKUP_DEF] + \\ rpt (first_x_assum $ qspec_then ‘ptr’ assume_tac \\ gvs [])) >- ( - Cases_on `op = ThunkOp ForceThunk` \\ gvs [] - >- ( - fs [bvlSemTheory.evaluate_def] \\ rw [] \\ fs [] - \\ fs [case_eq_thms] \\ rveq \\ fs [] - \\ gvs [AllCaseEqs()] - >- ( - imp_res_tac evaluate_refs_SUBSET - \\ gvs [EVERY_EL] \\ rw [] - \\ irule bv_ok_SUBSET_IMP - \\ goal_assum drule \\ gvs []) - >- ( - gvs [EVERY_EL] \\ rw [] - \\ rpt (first_x_assum drule \\ rw []) - \\ gvs [oneline bvlSemTheory.update_thunk_def, AllCaseEqs(), - bvlSemTheory.store_thunk_def] - \\ `bv_ok s''.refs (EL n env)` by ( - imp_res_tac evaluate_refs_SUBSET - \\ gvs [dec_clock_def] - \\ irule bv_ok_SUBSET_IMP - \\ goal_assum drule \\ gvs []) - \\ gvs [] - \\ irule bv_ok_SUBSET_IMP \\ rw [] - \\ goal_assum $ drule_at Any \\ gvs [FLOOKUP_DEF, ABSORPTION]) - >- ( - imp_res_tac evaluate_refs_SUBSET - \\ gvs [EVERY_EL] \\ rw [] - \\ irule bv_ok_SUBSET_IMP - \\ goal_assum drule \\ gvs [])) - \\ fs [bvlSemTheory.evaluate_def] \\ rw [] \\ fs [] - \\ fs [case_eq_thms] \\ rveq \\ fs [] - \\ imp_res_tac evaluate_IMP_bv_ok \\ fs [] - \\ ( - do_app_ok - |> REWRITE_RULE [CONJ_ASSOC] - |> ONCE_REWRITE_RULE [CONJ_COMM] |> GEN_ALL |> drule) - \\ fs [EVERY_REVERSE]) + gvs [bvlSemTheory.evaluate_def, AllCaseEqs()] + \\ rpt (FULL_CASE_TAC \\ gvs []) + \\ drule (GEN_ALL evaluate_IMP_bv_ok) \\ rw []) \\ fs[bvlSemTheory.evaluate_def] \\ rw [] \\ fs [] \\ fs [case_eq_thms] \\ rveq \\ fs [] \\ imp_res_tac evaluate_SING \\ fs[] \\ rveq \\ fs [] @@ -811,6 +713,8 @@ Proof \\ FIRST_X_ASSUM MATCH_MP_TAC \\ IMP_RES_TAC bvlPropsTheory.evaluate_IMP_LENGTH \\ full_simp_tac(srw_ss())[AC ADD_COMM ADD_ASSOC]) + THEN1 (gvs [] \\ rpt (PURE_CASE_TAC \\ gvs []) + \\ gvs [oneline bvlSemTheory.dest_thunk_def, AllCaseEqs(), EL_APPEND]) QED val iEval_def = bviSemTheory.evaluate_def; @@ -1371,6 +1275,11 @@ Proof \\ simp[iEval_append,iEval_def,compile_int_thm] \\ BasicProvers.EVERY_CASE_TAC \\ full_simp_tac(srw_ss())[iEval_def,compile_int_thm]) + >>~ [‘dest_thunk’] + >- gvs [AllCaseEqs()] + >- ( + rpt (PURE_CASE_TAC \\ gvs []) + \\ unabbrev_all_tac \\ gvs [EL_APPEND]) \\ full_simp_tac(srw_ss())[iEval_def] \\ TRY (FIRST_X_ASSUM (MP_TAC o Q.SPECL [`n`,`vs`]) \\ full_simp_tac(srw_ss())[] \\ NO_TAC) \\ FIRST_X_ASSUM (MP_TAC o Q.SPECL [`n2`]) \\ full_simp_tac(srw_ss())[] @@ -1746,6 +1655,7 @@ Theorem eval_ind_alt: P (xs,env,s) ⇒ P ([Let xs x2],env,s)) ∧ (∀x1 env s. P ([x1],env,s) ⇒ P ([Raise x1],env,s)) ∧ + (∀op xs env s. P (xs,env,s) ⇒ P ([Op op xs],env,s)) ∧ (∀x1 x2 env s1. (∀v3 s v8 v. evaluate ([x1],env,s1) = (v3,s) ∧ v3 = Rerr v8 ∧ @@ -1753,14 +1663,15 @@ Theorem eval_ind_alt: P ([x2],v::env,s)) ∧ (∀xs env. list_size exp_size xs <= exp_size x1 ⇒ P (xs,env,s1)) ⇒ P ([Handle x1 x2],env,s1)) ∧ - (∀op xs env s. - (∀v6 s' vs v1 v. - evaluate (xs,env,s) = (v6,s') ∧ v6 = Rval vs ∧ - op = ThunkOp ForceThunk ∧ - dest_thunk vs s'.refs = IsThunk v1 v ∧ v1 = NotEvaluated ∧ - s'.clock ≠ 0 ⇒ - P ([AppUnit],[v],dec_clock 1 s')) ∧ P (xs,env,s) ⇒ - P ([Op op xs],env,s)) ∧ + (∀force_loc n env s. + (∀thunk_v v1 v v' args exp. + n < LENGTH env ∧ thunk_v = EL n env ∧ + dest_thunk thunk_v s.refs = IsThunk v1 v ∧ v1 = NotEvaluated ∧ + s.clock ≠ 0 ∧ + find_code (SOME force_loc) [thunk_v; v] s.code = SOME v' ∧ + v' = (args,exp) ∧ s.clock ≠ 0 ⇒ + P ([exp],args,dec_clock 1 s)) ⇒ + P ([Force force_loc n],env,s)) ∧ (∀x env s. (s.clock ≠ 0 ⇒ P ([x],env,dec_clock 1 s)) ⇒ P ([Tick x],env,s)) ∧ @@ -2282,143 +2193,8 @@ Proof \\ imp_res_tac compile_exps_LENGTH \\ fs [NULL_EQ,LENGTH_NIL] \\ Cases_on `xs` \\ fs [bviSemTheory.evaluate_def]) - \\ Cases_on `op = ThunkOp ForceThunk` - >- ( - gvs [] \\ rw [GSYM PULL_FORALL] - \\ gvs [compile_op_def, evaluate_def] - \\ qrefinel [`_`, `_`, `c + c'`] \\ gvs [inc_clock_def] - \\ `∀c'. evaluate (c1,MAP (adjust_bv b2) env, - t1 with clock := c + t1.clock + c') = - (Rval (MAP (adjust_bv b2) a), - t2 with clock := t2.clock + c')` by ( - rw [] \\ drule evaluate_add_clock \\ rw [inc_clock_def]) - \\ gvs [AllCaseEqs(), PULL_EXISTS] - \\ gvs [oneline bvlSemTheory.dest_thunk_def, dest_thunk_def, AllCaseEqs(), - adjust_bv_def, PULL_EXISTS] - \\ drule_all state_rel_FLOOKUP_Thunk \\ gvs [PULL_EXISTS] \\ strip_tac - >- ( - qrefinel [`0`, `_`, `b2`] \\ gvs [dest_thunk_def] - \\ `t2 with clock := t2.clock = t2` by gvs [state_component_equality] - \\ gvs []) - >- ( - qrefinel [`0`, `t2`, `b2`] \\ gvs [dest_thunk_def] - \\ gvs [state_component_equality, state_rel_def]) - >- ( - rename1 `state_rel b2 s2 t2` - \\ `s2.clock = t2.clock` by gvs [state_rel_def] \\ gvs [] - \\ `state_rel b2 (dec_clock 1 s2) (dec_clock 1 t2)` by - gvs [state_rel_def, bvlSemTheory.dec_clock_def, dec_clock_def] \\ gvs [] - \\ last_x_assum $ drule_at (Pat `state_rel _ _ _`) - \\ simp [bvlSemTheory.AppUnit_def, compile_exps_def, compile_op_def, - compile_int_def] - \\ impl_tac - >- ( - rw [handle_ok_def, aux_code_installed_def] - >- ( - qpat_x_assum `evaluate _ = (_,s2)` assume_tac - \\ drule evaluate_ok \\ rw [] - \\ gvs [state_ok_def, bvlSemTheory.dec_clock_def]) - >- ( - `state_ok s2` by ( - qpat_x_assum `evaluate _ = (_,s2)` assume_tac - \\ drule evaluate_ok \\ rw []) \\ gvs [] - \\ pop_assum mp_tac - \\ rw [state_ok_def] - \\ pop_assum $ qspec_then `ptr` assume_tac \\ gvs []) - >- ( - irule evaluate_global_mono - \\ goal_assum $ drule_at Any \\ gvs [])) - \\ rw [] - \\ gvs [GSYM PULL_FORALL, dec_clock_def] - \\ gvs [GSYM AppUnit_def] - \\ qrefinel [`c'`, `_`, `b2'`] \\ gvs [] - \\ `MAP (adjust_bv b2) env = MAP (adjust_bv b2') env` by ( - full_simp_tac(srw_ss())[MAP_EQ_f] \\ REPEAT STRIP_TAC - \\ MATCH_MP_TAC (GEN_ALL bv_ok_IMP_adjust_bv_eq) - \\ qexists_tac `s2.refs` - \\ full_simp_tac(srw_ss())[EVERY_MEM] \\ RES_TAC - \\ IMP_RES_TAC evaluate_refs_SUBSET - \\ REPEAT STRIP_TAC THEN1 METIS_TAC [bv_ok_SUBSET_IMP]) - \\ gvs [dest_thunk_def, PULL_EXISTS] - \\ `∀a. a ∈ FDOM s.refs ⇒ b2 a = b2' a` by ( - rw [] - \\ first_x_assum irule \\ gvs [] - \\ imp_res_tac evaluate_refs_SUBSET \\ metis_tac [SUBSET_THM]) - \\ gvs [] - \\ imp_res_tac evaluate_SING \\ gvs [] - \\ `state_ok s''` by ( - qpat_x_assum `evaluate _ = (_,s2)` assume_tac - \\ drule evaluate_ok \\ impl_tac - >- gvs [] - \\ rw [] - \\ qpat_x_assum `evaluate _ = (_,s'')` assume_tac - \\ drule evaluate_ok \\ impl_tac - >- ( - rw [] - >- gvs [evaluate_ok_lemma] - >- ( - qpat_x_assum `state_ok s2` mp_tac - \\ rw [state_ok_def] - \\ pop_assum $ qspec_then `ptr` assume_tac \\ gvs [])) - \\ gvs []) - \\ gvs [bvlSemTheory.update_thunk_def, update_thunk_def] - \\ gvs [AllCaseEqs()] - \\ gvs [oneline bvlSemTheory.dest_thunk_def, oneline dest_thunk_def, - AllCaseEqs(), adjust_bv_def, PULL_EXISTS] - \\ ( - `ptr ∈ FDOM s2.refs` by gvs [FLOOKUP_DEF] - \\ first_x_assum drule \\ strip_tac \\ gvs [] - \\ gvs [bvlSemTheory.store_thunk_def, store_thunk_def, AllCaseEqs(), - PULL_EXISTS, SF ETA_ss] - \\ drule_all state_rel_FLOOKUP_Thunk \\ strip_tac \\ gvs [] - \\ TRY (drule_all state_rel_FLOOKUP_valueArray \\ rw []) - \\ TRY (drule_all state_rel_FLOOKUP_byteArray \\ rw []) - \\ `ptr ∈ FDOM s''.refs` by gvs [FLOOKUP_DEF] - \\ drule_all state_rel_update_thunk \\ rw [] - \\ qmatch_goalsub_abbrev_tac - `state_rel _ (_ with refs := _ |+ (_,Thunk mo va)) _` - \\ first_x_assum $ qspecl_then [`va`, `mo`] assume_tac \\ gvs [] - \\ unabbrev_all_tac \\ gvs [adjust_bv_def, SF ETA_ss])) - >- ( - rename1 `state_rel b2 s2 t2` - \\ `s2.clock = t2.clock` by gvs [state_rel_def] \\ gvs [] - \\ `state_rel b2 (dec_clock 1 s2) (dec_clock 1 t2)` by - gvs [state_rel_def, bvlSemTheory.dec_clock_def, dec_clock_def] \\ gvs [] - \\ last_x_assum $ drule_at (Pat `state_rel _ _ _`) - \\ simp [bvlSemTheory.AppUnit_def, compile_exps_def, compile_op_def, - compile_int_def] - \\ impl_tac - >- ( - rw [handle_ok_def, aux_code_installed_def] - >- ( - qpat_x_assum `evaluate _ = (_,s2)` assume_tac - \\ drule evaluate_ok \\ rw [] - \\ gvs [state_ok_def, bvlSemTheory.dec_clock_def]) - >- ( - `state_ok s2` by ( - qpat_x_assum `evaluate _ = (_,s2)` assume_tac - \\ drule evaluate_ok \\ rw []) \\ gvs [] - \\ pop_assum mp_tac - \\ rw [state_ok_def] - \\ pop_assum $ qspec_then `ptr` assume_tac \\ gvs []) - >- ( - irule evaluate_global_mono - \\ goal_assum $ drule_at Any \\ gvs [])) - \\ rw [] - \\ gvs [GSYM PULL_FORALL, dec_clock_def] - \\ gvs [GSYM AppUnit_def] - \\ qrefinel [`c'`, `_`, `b2'`] \\ gvs [] - \\ `MAP (adjust_bv b2) env = MAP (adjust_bv b2') env` by ( - full_simp_tac(srw_ss())[MAP_EQ_f] \\ REPEAT STRIP_TAC - \\ MATCH_MP_TAC (GEN_ALL bv_ok_IMP_adjust_bv_eq) - \\ qexists_tac `s2.refs` - \\ full_simp_tac(srw_ss())[EVERY_MEM] \\ RES_TAC - \\ IMP_RES_TAC evaluate_refs_SUBSET - \\ REPEAT STRIP_TAC THEN1 METIS_TAC [bv_ok_SUBSET_IMP]) - \\ gvs [dest_thunk_def, PULL_EXISTS] - \\ rw [] - \\ first_x_assum irule \\ gvs [] - \\ imp_res_tac evaluate_refs_SUBSET \\ metis_tac [SUBSET_THM])) + \\ Cases_on ‘op = ThunkOp ForceThunk’ + >- gvs [bvlSemTheory.do_app_def, AllCaseEqs()] \\ REPEAT STRIP_TAC \\ Cases_on `do_app op (REVERSE a) s5` \\ full_simp_tac(srw_ss())[] \\ TRY( @@ -4085,6 +3861,57 @@ Proof \\ IMP_RES_TAC evaluate_ok \\ full_simp_tac(srw_ss())[] \\ REV_FULL_SIMP_TAC std_ss [] \\ full_simp_tac(srw_ss())[EVERY_MEM] \\ RES_TAC)) + THEN1 (* Force *) + (note_tac "Force" + \\ gvs [AllCaseEqs()] + >- ( + last_x_assum kall_tac + \\ gvs [evaluate_def, EL_MAP, AllCaseEqs(), PULL_EXISTS, + oneline bvlSemTheory.dest_thunk_def, oneline dest_thunk_def, + adjust_bv_def] + \\ drule_all state_rel_FLOOKUP_Thunk \\ rw [] \\ gvs [] + \\ goal_assum drule \\ gvs [inc_clock_def] + \\ qexists ‘0’ \\ gvs [state_rel_def]) + >- ( + gvs [evaluate_def, EL_MAP, AllCaseEqs(), PULL_EXISTS, + oneline bvlSemTheory.dest_thunk_def, oneline dest_thunk_def, + adjust_bv_def] + \\ drule_all state_rel_FLOOKUP_Thunk \\ rw [] \\ gvs [] + \\ goal_assum drule \\ gvs [inc_clock_def] + \\ qexistsl [‘t1’, ‘0’] \\ gvs [state_rel_def, state_component_equality]) + >- ( + gvs [oneline bvlSemTheory.dest_thunk_def, oneline dest_thunk_def, + AllCaseEqs()] + \\ ‘state_rel b1 (dec_clock 1 s) (dec_clock 1 t1)’ + by gvs [state_rel_def, dec_clock_def, bvlSemTheory.dec_clock_def] + \\ last_x_assum $ drule_at (Pat ‘state_rel _ _ _’) \\ gvs [] + \\ gvs [find_code_def, AllCaseEqs(), bv_ok_def] + \\ pop_assum kall_tac + \\ qpat_x_assum ‘state_rel _ _ _’ mp_tac + \\ rw [Once state_rel_def] + \\ first_x_assum drule \\ rw [] + \\ pairarg_tac \\ gvs [] + \\ first_x_assum drule \\ gvs [] + \\ impl_tac \\ rw [] + >- gvs [state_ok_def, bvlSemTheory.dec_clock_def] + >- gvs [FLOOKUP_DEF] + >- ( + qpat_x_assum ‘state_ok _’ mp_tac + \\ rw [state_ok_def] + \\ first_x_assum $ qspec_then ‘ptr’ assume_tac \\ gvs []) + \\ gvs [adjust_bv_def, inc_clock_def, dec_clock_def] + \\ goal_assum $ drule_at (Pat ‘state_rel _ _ _’) \\ gvs [] + \\ simp [evaluate_def, EL_MAP, adjust_bv_def, dest_thunk_def] \\ gvs [] + \\ last_x_assum $ qspec_then ‘ptr’ assume_tac + \\ gvs [find_code_def, AllCaseEqs(), PULL_EXISTS, dec_clock_def] + \\ imp_res_tac compile_exps_SING \\ gvs [] + \\ imp_res_tac bvi_letProofTheory.evaluate_compile_exp \\ gvs [] + \\ goal_assum $ drule_at (Pat ‘evaluate _ = _’) \\ gvs [] + \\ gvs [MAP_EQ_f] \\ rw [] + \\ irule (GEN_ALL bv_ok_IMP_adjust_bv_eq) + \\ qexists ‘s.refs’ \\ gvs [] + \\ imp_res_tac evaluate_refs_SUBSET \\ gvs [dec_clock_def] + \\ imp_res_tac bv_ok_SUBSET_IMP \\ gvs [EVERY_MEM])) THEN1 (* Tick *) (note_tac "Tick" \\ `?c1 aux1 n1. compile_exps n [x] = (c1,aux1,n1)` by METIS_TAC [PAIR] diff --git a/compiler/backend/semantics/bviPropsScript.sml b/compiler/backend/semantics/bviPropsScript.sml index 46bb6c25a8..61ebfc8871 100644 --- a/compiler/backend/semantics/bviPropsScript.sml +++ b/compiler/backend/semantics/bviPropsScript.sml @@ -734,6 +734,7 @@ Definition get_code_labels_def: (get_code_labels (Let es e) = BIGUNION (set (MAP get_code_labels es)) ∪ get_code_labels e) ∧ (get_code_labels (Raise e) = get_code_labels e) ∧ (get_code_labels (Tick e) = get_code_labels e) ∧ + (get_code_labels (Force loc v) = {loc}) ∧ (get_code_labels (Call _ d es h) = (case d of NONE => {} | SOME n => {n}) ∪ (case h of NONE => {} | SOME e => get_code_labels e) ∪ From e63236ff5971b212509aac43a8cad568a12f0006 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Sun, 17 Aug 2025 11:51:35 +0300 Subject: [PATCH 052/112] Fix `bvl_const` --- compiler/backend/bvl_constScript.sml | 14 ++++++++-- .../backend/proofs/bvl_constProofScript.sml | 27 ++++++++++++++++--- compiler/backend/semantics/bvlSemScript.sml | 18 ------------- 3 files changed, 36 insertions(+), 23 deletions(-) diff --git a/compiler/backend/bvl_constScript.sml b/compiler/backend/bvl_constScript.sml index c8689f6856..044b2d1983 100644 --- a/compiler/backend/bvl_constScript.sml +++ b/compiler/backend/bvl_constScript.sml @@ -318,7 +318,12 @@ Definition compile_def: [Raise (HD (compile env [x1]))]) /\ (compile env [Op op xs] = [SmartOp op (compile env xs)]) /\ (compile env [Tick x] = [Tick (HD (compile env [x]))]) /\ - (compile env [Force loc v] = [Force loc v]) /\ + (compile env [Force loc v] = + dtcase LLOOKUP env v of + | NONE => [Force loc v] + | SOME NONE => [Force loc v] + | SOME (SOME (Var i)) => [Force loc (v + i)] + | SOME (SOME x) => [Force loc v]) /\ (compile env [Call t dest xs] = [Call t dest (compile env xs)]) End @@ -346,7 +351,12 @@ Definition compile_sing_def: Raise (compile_sing env x1)) /\ (compile_sing env (Op op xs) = SmartOp op (compile_list env xs)) /\ (compile_sing env (Tick x) = Tick (compile_sing env x)) /\ - (compile_sing env (Force loc v) = Force loc v) ∧ + (compile_sing env (Force loc v) = + dtcase LLOOKUP env v of + | NONE => Force loc v + | SOME NONE => Force loc v + | SOME (SOME (Var i)) => Force loc (v + i) + | SOME (SOME x) => Force loc v) ∧ (compile_sing env (Call t dest xs) = Call t dest (compile_list env xs)) ∧ (compile_list env [] = []) /\ diff --git a/compiler/backend/proofs/bvl_constProofScript.sml b/compiler/backend/proofs/bvl_constProofScript.sml index dc3e156e8b..b5cfc2c62c 100644 --- a/compiler/backend/proofs/bvl_constProofScript.sml +++ b/compiler/backend/proofs/bvl_constProofScript.sml @@ -11,7 +11,9 @@ Definition v_rel_def: v_rel (:'c) (:'ffi) a x y xs ys = case a of | Var n => LLOOKUP ys n = SOME x - | Op _ _ => !(s:('c,'ffi) bvlSem$state) env. evaluate ([a],env,s) = (Rval [x],s) + | Op _ _ => + (x = y) ∧ + !(s:('c,'ffi) bvlSem$state) env. evaluate ([a],env,s) = (Rval [x],s) | _ => F End @@ -295,7 +297,15 @@ Proof \\ res_tac \\ rw [] \\ Cases_on `e` \\ fs [] \\ rw [] \\ fs [] \\ first_x_assum match_mp_tac \\ fs [env_rel_def]) - >>~- ([`dest_thunk`], cheat) + >~ [‘dest_thunk’] >- ( + imp_res_tac env_rel_length \\ gvs [] + \\ rpt (PURE_CASE_TAC \\ gvs []) + \\ gvs [evaluate_def, AllCaseEqs(), PULL_EXISTS] + >>~- ([‘LLOOKUP _ _ = NONE’], drule env_rel_LLOOKUP_NONE \\ rw []) + >>~- ([‘LLOOKUP _ _ = SOME NONE’], drule env_rel_LLOOKUP_NONE \\ rw []) + \\ ( + drule_all env_rel_LOOKUP_SOME \\ rw [] + \\ gvs [v_rel_def, LLOOKUP_DROP, LLOOKUP_EQ_EL, EL_DROP])) \\ TRY (match_mp_tac SmartOp_thm) \\ fs [evaluate_def] \\ every_case_tac \\ fs [] \\ rw [] \\ fs [] \\ res_tac \\ fs [] \\ rw [] \\ fs [] \\ rw [] \\ fs [] @@ -403,7 +413,7 @@ Proof \\ fs[MEM_MAP, MEM_FILTER, IS_SOME_EXISTS, PULL_EXISTS] \\ simp[MEM_EL, PULL_EXISTS] \\ goal_assum(first_assum o mp_then Any mp_tac) \\ simp[] - \\ PURE_FULL_CASE_TAC \\ fs[] ) + \\ PURE_FULL_CASE_TAC \\ fs[]) >- ( rw[] \\ last_x_assum drule @@ -412,6 +422,17 @@ Proof >- metis_tac[] \\ imp_res_tac MEM_extract_list_code_labels \\ fs[]) + >- ( + CASE_TAC \\ gvs [] + \\ CASE_TAC \\ gvs [] + \\ rw [] + \\ Cases_on ‘x'' = loc’ \\ gvs [] + \\ asm_exists_tac \\ gvs [] + \\ gvs [LLOOKUP_THM] + \\ gvs [MEM_MAP, MEM_FILTER, IS_SOME_EXISTS, PULL_EXISTS] + \\ simp [MEM_EL, PULL_EXISTS] + \\ goal_assum (first_assum o mp_then Any mp_tac) \\ simp [] + \\ FULL_CASE_TAC \\ gvs []) QED Theorem compile_exp_code_labels: diff --git a/compiler/backend/semantics/bvlSemScript.sml b/compiler/backend/semantics/bvlSemScript.sml index f405a8b56f..d7ea67b650 100644 --- a/compiler/backend/semantics/bvlSemScript.sml +++ b/compiler/backend/semantics/bvlSemScript.sml @@ -513,24 +513,6 @@ Definition dest_thunk_def: dest_thunk _ refs = NotThunk End -(* -Definition store_thunk_def: - store_thunk ptr v refs = - case FLOOKUP refs ptr of - | SOME (Thunk NotEvaluated _) => SOME (refs |+ (ptr,v)) - | _ => NONE -End - -Definition update_thunk_def: - update_thunk [RefPtr _ ptr] refs [v] = - (case dest_thunk [v] refs of - | NotThunk => store_thunk ptr (Thunk Evaluated v) refs - | _ => NONE) ∧ - update_thunk _ _ _ = NONE -End - -*) - (* The evaluation is defined as a clocked functional version of a conventional big-step operational semantics. *) From c931e7ed8d30a50f3d369ecd79946a5a0da72d95 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Sun, 17 Aug 2025 12:11:05 +0300 Subject: [PATCH 053/112] Fix `bvi_let` --- compiler/backend/bvi_letScript.sml | 10 ++++++++-- compiler/backend/proofs/bvi_letProofScript.sml | 14 ++++++++++++-- 2 files changed, 20 insertions(+), 4 deletions(-) diff --git a/compiler/backend/bvi_letScript.sml b/compiler/backend/bvi_letScript.sml index 040287c967..9c46356a76 100644 --- a/compiler/backend/bvi_letScript.sml +++ b/compiler/backend/bvi_letScript.sml @@ -90,7 +90,10 @@ Definition compile_def: [Raise (HD (compile env d [x1]))]) /\ (compile env d [Op op xs] = [Op op (compile env d xs)]) /\ (compile env d [Tick x] = [Tick (HD (compile env d [x]))]) /\ - (compile env d [Force loc v] = [Force loc v]) /\ + (compile env d [Force loc v] = + case LLOOKUP env v of + | SOME n => [Force loc (v + n)] + | _ => [Force loc (v + d)]) /\ (compile env d [Call t dest xs h] = [Call t dest (compile env d xs) (case h of NONE => NONE @@ -128,7 +131,10 @@ Definition compile_sing_def: (Raise ((compile_sing env d x1)))) /\ (compile_sing env d (Op op xs) = (Op op (compile_list env d xs))) /\ (compile_sing env d (Tick x) = (Tick (compile_sing env d x))) /\ - (compile_sing env d (Force loc v) = (Force loc v)) /\ + (compile_sing env d (Force loc v) = + case LLOOKUP env v of + | SOME n => Force loc (v + n) + | _ => Force loc (v + d)) /\ (compile_sing env d (Call t dest xs h) = (Call t dest (compile_list env d xs) (case h of NONE => NONE diff --git a/compiler/backend/proofs/bvi_letProofScript.sml b/compiler/backend/proofs/bvi_letProofScript.sml index cc8170b3df..e904169b94 100644 --- a/compiler/backend/proofs/bvi_letProofScript.sml +++ b/compiler/backend/proofs/bvi_letProofScript.sml @@ -257,8 +257,18 @@ Proof \\ pop_assum $ drule_at $ Pos $ el 2 \\ gvs [] \\ disch_then drule \\ impl_tac >- (CCONTR_TAC \\ gvs []) \\ gvs []) - \\ Cases_on `∃force_loc n. h = Force force_loc n` \\ gvs [] - THEN1 cheat + \\ Cases_on ‘∃force_loc n. h = Force force_loc n’ \\ gvs [] + >- ( + imp_res_tac env_rel_length \\ gvs [] + \\ gvs [evaluate_def, AllCaseEqs()] + \\ gvs [compile_def, evaluate_def] + \\ CASE_TAC \\ gvs [] + >>~- ([‘LLOOKUP ax n = NONE’], + gvs [evaluate_def] \\ drule_all env_rel_LLOOKUP_NONE \\ rw []) + \\ ( + drule env_rel_LOOKUP_SOME \\ gvs [v_rel_def] + \\ disch_then drule \\ gvs [] \\ rw [] + \\ gvs [evaluate_def, LLOOKUP_EQ_EL, EL_DROP])) \\ reverse (Cases_on `?ys y. h = Let ys y` \\ fs []) THEN1 (Cases_on `h` \\ fs []) \\ fs [] \\ rpt (qpat_x_assum `T` kall_tac) \\ rveq \\ fs [evaluate_def] From 48881ef2d154afe7e711f24fb29c8e9da8656fdf Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Mon, 18 Aug 2025 01:05:46 +0300 Subject: [PATCH 054/112] Fix `bvi_tailrecProof`. TODO cleanup --- .../backend/proofs/bvi_tailrecProofScript.sml | 113 +++++++++++++++--- 1 file changed, 96 insertions(+), 17 deletions(-) diff --git a/compiler/backend/proofs/bvi_tailrecProofScript.sml b/compiler/backend/proofs/bvi_tailrecProofScript.sml index 9bdd1b22ec..28638f1039 100644 --- a/compiler/backend/proofs/bvi_tailrecProofScript.sml +++ b/compiler/backend/proofs/bvi_tailrecProofScript.sml @@ -1259,12 +1259,6 @@ Proof Cases_on `op` \\ fs [op_type_def] QED -Triviality to_op_not_ForceThunk[simp]: - ∀op. to_op op ≠ ThunkOp ForceThunk -Proof - strip_tac \\ gvs [oneline to_op_def, AllCaseEqs()] -QED - Theorem evaluate_rewrite_tail: ∀xs ^s env1 r t opt s' acc env2 loc ts ty. evaluate (xs, env1, s) = (r, t) ∧ @@ -1630,16 +1624,7 @@ Proof \\ simp [LEFT_EXISTS_AND_THM, CONJ_ASSOC] \\ conj_tac >- - ((*Cases_on `op = ThunkOp ForceThunk` - >- ( - gvs [] - \\ last_assum $ qspecl_then [`xs`, `s`] mp_tac \\ gvs[] - \\ `env_rel ty F acc env1 env2` by fs [env_rel_def] \\ gvs [] - \\ rpt (disch_then drule) \\ rw [] - \\ gvs [AllCaseEqs(), PULL_EXISTS] - >- (imp_res_tac state_rel_do_app \\ gvs []) - >- (imp_res_tac state_rel_do_app_err \\ gvs []))*) - gvs [] + (gvs [] \\ first_x_assum (qspecl_then [`xs`, `s`] mp_tac) \\ simp [bviTheory.exp_size_def] \\ `env_rel ty F acc env1 env2` by fs [env_rel_def] @@ -2000,7 +1985,101 @@ Proof \\ fs [check_op_def, try_swap_def, opbinargs_def, get_bin_args_def, apply_op_def] \\ rw [] \\ metis_tac [is_rec_term_ok]) \\ Cases_on `∃force_loc n. h = Force force_loc n` \\ gvs [] - >- cheat + >- ( + gvs [scan_expr_def] + \\ simp [evaluate_def] + \\ `LENGTH env1 ≤ LENGTH env2` by metis_tac [env_rel_def, IS_PREFIX_LENGTH] + \\ rw [] \\ gvs [AllCaseEqs(), PULL_EXISTS] + >- ( + gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ `EL n env2 = EL n env1` by ( + gvs [env_rel_def] + \\ drule_then drule is_prefix_el \\ rw []) + \\ gvs [] + \\ `FLOOKUP s'.refs ptr = FLOOKUP s.refs ptr` by gvs [state_rel_def] + \\ gvs [] \\ rw []) + >- ( + gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ `EL n env2 = EL n env1` by ( + gvs [env_rel_def] + \\ drule_then drule is_prefix_el \\ rw []) + \\ gvs [] + \\ `FLOOKUP s'.refs ptr = FLOOKUP s.refs ptr` by gvs [state_rel_def] + \\ gvs [] + \\ `s'.clock = 0` by gvs [state_rel_def] \\ gvs [] \\ rw []) + \\ last_assum $ qspecl_then [`[exp]`, `dec_clock 1 s`] mp_tac + \\ gvs [dec_clock_def] + \\ disch_then drule + \\ gvs [find_code_def, oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] + \\ `state_rel (s with clock := s.clock - 1) (s' with clock := s'.clock - 1)` + by gvs [state_rel_def] + \\ disch_then $ drule_at (Pat `state_rel _ _`) \\ gvs [] + \\ `ty_rel [RefPtr v0 ptr; v] [Any; Any]` by gvs [ty_rel_def] + \\ disch_then $ drule_at (Pat `ty_rel _ _`) \\ gvs [] + \\ disch_then $ qspec_then `F` mp_tac \\ simp [env_rel_def] + \\ disch_then $ qspec_then `[RefPtr v0 ptr; v]` mp_tac \\ rw [] + \\ `EL n env2 = EL n env1` by ( + gvs [env_rel_def] + \\ drule_then drule is_prefix_el \\ rw []) + \\ gvs [] + \\ `s.refs = s'.refs` by gvs [state_rel_def] \\ gvs [] + \\ `s.clock = s'.clock` by gvs [state_rel_def] \\ gvs [PULL_EXISTS] + \\ qpat_x_assum `state_rel (s with clock := _) (s' with clock := _)` + assume_tac + \\ drule state_rel_code_rel \\ simp [code_rel_def] + \\ disch_then drule \\ rw [] + \\ Cases_on `check_exp force_loc 2 exp` \\ gvs [] + \\ gvs [compile_exp_def, AllCaseEqs()] + \\ pairarg_tac \\ gvs [] + \\ imp_res_tac scan_expr_not_Noop + \\ drule evaluate_let_wrap + \\ qabbrev_tac `a = [RefPtr v0 ptr; v]` + \\ disch_then $ qspecl_then [`opt'`, `a`, + `s' with clock := s'.clock - 1`] assume_tac + \\ `LENGTH a = 2` by (unabbrev_all_tac \\ gvs []) + \\ gvs [] + \\ ntac 2 (pop_assum kall_tac) + \\ first_assum (qspecl_then [`[exp]`,`dec_clock 1 s`] mp_tac) + \\ impl_tac >- (imp_res_tac evaluate_clock \\ fs [dec_clock_def]) + \\ sg `env_rel (op_type x) T (LENGTH a) a (a ++ [op_id_val x] ++ a)` + >- + (Cases_on `x` + \\ fs [op_id_val_def, op_type_def, env_rel_def, EL_LENGTH_APPEND, + EL_APPEND1, IS_PREFIX_APPEND, bvlSemTheory.v_to_list_def]) + \\ sg `ty_rel a [Any; Any]` + >- fs [ty_rel_def, LIST_REL_EL_EQN, EL_REPLICATE] + \\ gvs [dec_clock_def] + \\ rpt (disch_then drule) \\ fs [] + \\ disch_then (qspec_then `force_loc` mp_tac) + \\ rw [] + \\ unabbrev_all_tac \\ gvs [] + \\ `REPLICATE 2 Any = [Any;Any]` by gvs [REPLICATE_compute] \\ gvs [] + \\ first_x_assum (qspecl_then [`x`,`n'`] mp_tac) \\ rw [] \\ fs [] + \\ gvs [optimized_code_def, compile_exp_def, check_exp_def] + \\ gvs [evaluate_def, apply_op_def, AllCaseEqs()] + >- ( + drule (GEN_ALL (INST_TYPE [alpha|->``:num#'c``,beta|->``:'ffi``] (SPEC_ALL scan_expr_ty_rel))) + \\ rpt (disch_then drule) \\ strip_tac \\ fs [] + \\ pop_assum mp_tac \\ fs [] \\ once_rewrite_tac [ty_rel_def] \\ strip_tac + \\ fs [] + \\ PRED_ASSUM is_forall kall_tac + \\ Cases_on `x` + \\ gvs [op_type_def, to_op_def, do_app_def, do_app_aux_def, op_id_val_def, + bvlSemTheory.do_app_def, bvlSemTheory.v_to_list_def, + list_to_v_imp, oneline bvlSemTheory.do_int_app_def, AllCaseEqs()]) + >- ( + drule (GEN_ALL (INST_TYPE [alpha|->``:num#'c``,beta|->``:'ffi``] (SPEC_ALL scan_expr_ty_rel))) + \\ rpt (disch_then drule) \\ strip_tac \\ fs [] + \\ pop_assum mp_tac \\ fs [] \\ once_rewrite_tac [ty_rel_def] \\ strip_tac + \\ fs [] + \\ PRED_ASSUM is_forall kall_tac + \\ Cases_on `x` + \\ gvs [to_op_def, op_id_val_def, do_app_def, do_app_aux_def, + bvlSemTheory.do_app_def, bvlSemTheory.do_int_app_def, + bvl_to_bvi_id, op_type_def] + \\ fs [bvlSemTheory.v_to_list_def] + \\ fs [case_eq_thms, case_elim_thms, pair_case_eq, bool_case_eq] \\ rw [] + \\ fs [bvl_to_bvi_id, list_to_v_imp])) \\ Cases_on `∃ticks dest xs hdl. h = Call ticks dest xs hdl` \\ fs [] \\ rveq >- (simp [scan_expr_def, evaluate_def] From d18bb8c2dc396ff9f9822c934fbca62a94596bd6 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Mon, 18 Aug 2025 12:35:36 +0300 Subject: [PATCH 055/112] Cleanup `bvi_tailrecProof` --- .../backend/proofs/bvi_tailrecProofScript.sml | 118 +++++++----------- 1 file changed, 47 insertions(+), 71 deletions(-) diff --git a/compiler/backend/proofs/bvi_tailrecProofScript.sml b/compiler/backend/proofs/bvi_tailrecProofScript.sml index 6e438a2c7e..608ab8db84 100644 --- a/compiler/backend/proofs/bvi_tailrecProofScript.sml +++ b/compiler/backend/proofs/bvi_tailrecProofScript.sml @@ -1984,102 +1984,78 @@ Proof \\ fs [bvl_to_bvi_id] \\ rw [] \\ fs [check_op_def, try_swap_def, opbinargs_def, get_bin_args_def, apply_op_def] \\ rw [] \\ metis_tac [is_rec_term_ok]) - \\ Cases_on `∃force_loc n. h = Force force_loc n` \\ gvs [] + \\ Cases_on ‘∃force_loc n. h = Force force_loc n’ \\ gvs [] >- ( - gvs [scan_expr_def] - \\ simp [evaluate_def] - \\ `LENGTH env1 ≤ LENGTH env2` by metis_tac [env_rel_def, IS_PREFIX_LENGTH] + gvs [scan_expr_def, evaluate_def] + \\ ‘LENGTH env1 ≤ LENGTH env2’ by metis_tac [env_rel_def, IS_PREFIX_LENGTH] + \\ imp_res_tac state_rel_const \\ gvs [] \\ rw [] \\ gvs [AllCaseEqs(), PULL_EXISTS] >- ( - gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] - \\ `EL n env2 = EL n env1` by ( - gvs [env_rel_def] - \\ drule_then drule is_prefix_el \\ rw []) - \\ gvs [] - \\ `FLOOKUP s'.refs ptr = FLOOKUP s.refs ptr` by gvs [state_rel_def] - \\ gvs [] \\ rw []) + gvs [oneline dest_thunk_def, env_rel_def, AllCaseEqs(), PULL_EXISTS] + \\ drule_then drule is_prefix_el \\ simp [] + \\ disch_then $ assume_tac o GSYM \\ gvs []) >- ( - gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] - \\ `EL n env2 = EL n env1` by ( - gvs [env_rel_def] - \\ drule_then drule is_prefix_el \\ rw []) - \\ gvs [] - \\ `FLOOKUP s'.refs ptr = FLOOKUP s.refs ptr` by gvs [state_rel_def] - \\ gvs [] - \\ `s'.clock = 0` by gvs [state_rel_def] \\ gvs [] \\ rw []) - \\ last_assum $ qspecl_then [`[exp]`, `dec_clock 1 s`] mp_tac + gvs [oneline dest_thunk_def, env_rel_def, AllCaseEqs(), PULL_EXISTS] + \\ drule_then drule is_prefix_el \\ simp [] + \\ disch_then $ assume_tac o GSYM \\ gvs []) + \\ last_assum $ qspecl_then [‘[exp]’, ‘dec_clock 1 s’] mp_tac \\ gvs [dec_clock_def] \\ disch_then drule \\ gvs [find_code_def, oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS] - \\ `state_rel (s with clock := s.clock - 1) (s' with clock := s'.clock - 1)` + \\ ‘state_rel (s with clock := s.clock - 1) (s' with clock := s'.clock - 1)’ by gvs [state_rel_def] - \\ disch_then $ drule_at (Pat `state_rel _ _`) \\ gvs [] - \\ `ty_rel [RefPtr v0 ptr; v] [Any; Any]` by gvs [ty_rel_def] - \\ disch_then $ drule_at (Pat `ty_rel _ _`) \\ gvs [] - \\ disch_then $ qspec_then `F` mp_tac \\ simp [env_rel_def] - \\ disch_then $ qspec_then `[RefPtr v0 ptr; v]` mp_tac \\ rw [] - \\ `EL n env2 = EL n env1` by ( - gvs [env_rel_def] - \\ drule_then drule is_prefix_el \\ rw []) - \\ gvs [] - \\ `s.refs = s'.refs` by gvs [state_rel_def] \\ gvs [] - \\ `s.clock = s'.clock` by gvs [state_rel_def] \\ gvs [PULL_EXISTS] - \\ qpat_x_assum `state_rel (s with clock := _) (s' with clock := _)` + \\ disch_then $ drule_at (Pat ‘state_rel _ _’) \\ gvs [] + \\ ‘ty_rel [RefPtr v0 ptr; v] [Any; Any]’ by gvs [ty_rel_def] + \\ disch_then $ drule_at (Pat ‘ty_rel _ _’) \\ gvs [] + \\ disch_then $ qspec_then ‘F’ mp_tac \\ simp [env_rel_def] + \\ disch_then $ qspec_then ‘[RefPtr v0 ptr; v]’ mp_tac \\ rw [] + \\ ‘EL n env2 = EL n env1’ by ( + gvs [env_rel_def] \\ drule_then drule is_prefix_el \\ rw []) + \\ gvs [PULL_EXISTS] + \\ qpat_x_assum ‘state_rel (s with clock := _) (s' with clock := _)’ assume_tac \\ drule state_rel_code_rel \\ simp [code_rel_def] \\ disch_then drule \\ rw [] - \\ Cases_on `check_exp force_loc 2 exp` \\ gvs [] + \\ Cases_on ‘check_exp force_loc 2 exp’ \\ gvs [] \\ gvs [compile_exp_def, AllCaseEqs()] \\ pairarg_tac \\ gvs [] \\ imp_res_tac scan_expr_not_Noop \\ drule evaluate_let_wrap - \\ qabbrev_tac `a = [RefPtr v0 ptr; v]` - \\ disch_then $ qspecl_then [`opt'`, `a`, - `s' with clock := s'.clock - 1`] assume_tac - \\ `LENGTH a = 2` by (unabbrev_all_tac \\ gvs []) - \\ gvs [] + \\ qabbrev_tac ‘a = [RefPtr v0 ptr; v]’ + \\ disch_then $ qspecl_then [‘opt'’, ‘a’, + ‘s' with clock := s'.clock - 1’] assume_tac + \\ ‘LENGTH a = 2’ by (unabbrev_all_tac \\ gvs []) \\ gvs [] \\ ntac 2 (pop_assum kall_tac) - \\ first_assum (qspecl_then [`[exp]`,`dec_clock 1 s`] mp_tac) + \\ first_assum (qspecl_then [‘[exp]’,‘dec_clock 1 s’] mp_tac) \\ impl_tac >- (imp_res_tac evaluate_clock \\ fs [dec_clock_def]) - \\ sg `env_rel (op_type x) T (LENGTH a) a (a ++ [op_id_val x] ++ a)` - >- - (Cases_on `x` - \\ fs [op_id_val_def, op_type_def, env_rel_def, EL_LENGTH_APPEND, + \\ ‘env_rel (op_type x) T (LENGTH a) a (a ++ [op_id_val x] ++ a)’ by ( + Cases_on ‘x’ + \\ gvs [op_id_val_def, op_type_def, env_rel_def, EL_LENGTH_APPEND, EL_APPEND1, IS_PREFIX_APPEND, bvlSemTheory.v_to_list_def]) - \\ sg `ty_rel a [Any; Any]` - >- fs [ty_rel_def, LIST_REL_EL_EQN, EL_REPLICATE] + \\ ‘ty_rel a [Any; Any]’ by gvs [ty_rel_def, LIST_REL_EL_EQN, EL_REPLICATE] \\ gvs [dec_clock_def] - \\ rpt (disch_then drule) \\ fs [] - \\ disch_then (qspec_then `force_loc` mp_tac) - \\ rw [] + \\ rpt (disch_then drule) \\ gvs [] + \\ disch_then (qspec_then ‘force_loc’ mp_tac) \\ rw [] \\ unabbrev_all_tac \\ gvs [] - \\ `REPLICATE 2 Any = [Any;Any]` by gvs [REPLICATE_compute] \\ gvs [] - \\ first_x_assum (qspecl_then [`x`,`n'`] mp_tac) \\ rw [] \\ fs [] + \\ ‘REPLICATE 2 Any = [Any; Any]’ by gvs [REPLICATE_compute] \\ gvs [] + \\ first_x_assum $ qspecl_then [‘x’,‘n'’] mp_tac \\ rw [] \\ gvs [] \\ gvs [optimized_code_def, compile_exp_def, check_exp_def] \\ gvs [evaluate_def, apply_op_def, AllCaseEqs()] - >- ( - drule (GEN_ALL (INST_TYPE [alpha|->``:num#'c``,beta|->``:'ffi``] (SPEC_ALL scan_expr_ty_rel))) - \\ rpt (disch_then drule) \\ strip_tac \\ fs [] - \\ pop_assum mp_tac \\ fs [] \\ once_rewrite_tac [ty_rel_def] \\ strip_tac - \\ fs [] + \\ ( + scan_expr_ty_rel + |> SPEC_ALL + |> INST_TYPE [alpha|->“:num#'c”,beta|->“:'ffi”] + |> GEN_ALL + |> drule + \\ rpt (disch_then drule) \\ strip_tac \\ gvs [] + \\ pop_assum mp_tac \\ gvs [] \\ once_rewrite_tac [ty_rel_def] + \\ strip_tac \\ gvs [] \\ PRED_ASSUM is_forall kall_tac - \\ Cases_on `x` + \\ Cases_on ‘x’ \\ gvs [op_type_def, to_op_def, do_app_def, do_app_aux_def, op_id_val_def, bvlSemTheory.do_app_def, bvlSemTheory.v_to_list_def, - list_to_v_imp, oneline bvlSemTheory.do_int_app_def, AllCaseEqs()]) - >- ( - drule (GEN_ALL (INST_TYPE [alpha|->``:num#'c``,beta|->``:'ffi``] (SPEC_ALL scan_expr_ty_rel))) - \\ rpt (disch_then drule) \\ strip_tac \\ fs [] - \\ pop_assum mp_tac \\ fs [] \\ once_rewrite_tac [ty_rel_def] \\ strip_tac - \\ fs [] - \\ PRED_ASSUM is_forall kall_tac - \\ Cases_on `x` - \\ gvs [to_op_def, op_id_val_def, do_app_def, do_app_aux_def, - bvlSemTheory.do_app_def, bvlSemTheory.do_int_app_def, - bvl_to_bvi_id, op_type_def] - \\ fs [bvlSemTheory.v_to_list_def] - \\ fs [case_eq_thms, case_elim_thms, pair_case_eq, bool_case_eq] \\ rw [] - \\ fs [bvl_to_bvi_id, list_to_v_imp])) + list_to_v_imp, oneline bvlSemTheory.do_int_app_def, + AllCaseEqs()])) \\ Cases_on `∃ticks dest xs hdl. h = Call ticks dest xs hdl` \\ fs [] \\ rveq >- (simp [scan_expr_def, evaluate_def] From d783e87646819adc3b9e4f63e08169be6844d745 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Mon, 18 Aug 2025 14:14:47 +0200 Subject: [PATCH 056/112] Give Force semantics in dataSem --- compiler/backend/semantics/dataSemScript.sml | 112 ++++++++----------- 1 file changed, 45 insertions(+), 67 deletions(-) diff --git a/compiler/backend/semantics/dataSemScript.sml b/compiler/backend/semantics/dataSemScript.sml index 68063888d2..4d8eba47c5 100644 --- a/compiler/backend/semantics/dataSemScript.sml +++ b/compiler/backend/semantics/dataSemScript.sml @@ -1216,45 +1216,13 @@ Datatype: End Definition dest_thunk_def: - dest_thunk [RefPtr _ ptr] refs = + dest_thunk (RefPtr _ ptr) refs = (case lookup ptr refs of | NONE => BadRef | SOME (Thunk Evaluated v) => IsThunk Evaluated v | SOME (Thunk NotEvaluated v) => IsThunk NotEvaluated v | SOME _ => NotThunk) ∧ - dest_thunk vs refs = NotThunk -End - -Definition store_thunk_def: - store_thunk ptr v refs = - case lookup ptr refs of - | SOME (Thunk NotEvaluated _) => SOME (insert ptr v refs) - | _ => NONE -End - -Definition update_thunk_def: - update_thunk [RefPtr _ ptr] refs [v] = - (case dest_thunk [v] refs of - | NotThunk => store_thunk ptr (Thunk Evaluated v) refs - | _ => NONE) ∧ - update_thunk _ _ _ = NONE -End - -Definition AppUnit_def: - AppUnit = - Seq - (Seq - (Assign 1 (BlockOp (ElemAt 1)) [0] NONE) - (Assign 2 (BlockOp (EqualConst (Int 0))) [1] NONE)) - (If 2 - (Seq - (Seq - (Assign 3 (BlockOp (Cons 0)) [] NONE) - (Assign 4 (BlockOp (ElemAt 0)) [0] NONE)) - (Call NONE NONE [3; 0; 4] NONE)) - (Seq - (Assign 6 (BlockOp (Cons 0)) [] NONE) - (Call NONE (SOME bvl_num_stubs) [6; 0] NONE))) + dest_thunk v refs = NotThunk End Definition evaluate_def: @@ -1270,33 +1238,10 @@ Definition evaluate_def: | SOME s => (case get_vars args s.locals of | NONE => (SOME (Rerr(Rabort Rtype_error)),s) - | SOME xs => - if op = ThunkOp ForceThunk then - (case dest_thunk xs s.refs of - | BadRef => (SOME (Rerr (Rabort Rtype_error)),s) - | NotThunk => (SOME (Rerr (Rabort Rtype_error)),s) - | IsThunk Evaluated v => (NONE,set_var dest v s) - | IsThunk NotEvaluated f => - if s.clock = 0 then - (SOME (Rerr (Rabort Rtimeout_error)), flush_state T s) - else - case evaluate ( - AppUnit,s with <| - clock := s.clock - 1; - locals := insert 0 f LN |>) of - | (SOME (Rval x),s1) => - (case update_thunk xs s1.refs [x] of - | NONE => (SOME (Rerr (Rabort Rtype_error)),s1) - | SOME refs => - (NONE,set_var dest x (s1 with - <| refs := refs; - locals := s.locals |>))) - | (err,s) => (err,s)) - else - (case do_app op xs s of - | Rerr e => (SOME (Rerr e),flush_state T (install_sfs op s)) - | Rval (v,s) => - (NONE, set_var dest v (install_sfs op s))))) /\ + | SOME xs => (case do_app op xs s of + | Rerr e => (SOME (Rerr e),flush_state T (install_sfs op s)) + | Rval (v,s) => + (NONE, set_var dest v (install_sfs op s))))) /\ (evaluate (Tick,s) = if s.clock = 0 then (SOME (Rerr(Rabort Rtimeout_error)),flush_state T s) else (NONE,dec_clock s)) /\ @@ -1325,6 +1270,42 @@ Definition evaluate_def: | SOME x => if isBool T x then evaluate (c1,s) else if isBool F x then evaluate (c2,s) else (SOME (Rerr(Rabort Rtype_error)),s)) /\ + (evaluate (Force ret loc src,s) = + case get_var src s.locals of + | NONE => (SOME (Rerr(Rabort Rtype_error)),s) + | SOME thunk_v => + (case dest_thunk thunk_v s.refs of + | BadRef => (SOME (Rerr (Rabort Rtype_error)),s) + | NotThunk => (SOME (Rerr (Rabort Rtype_error)),s) + | IsThunk Evaluated v => + (case ret of + | NONE => (SOME (Rval v),flush_state F s) + | SOME (dest,names) => (NONE, set_var dest v s)) + | IsThunk NotEvaluated f => + (case find_code (SOME loc) [thunk_v; f] s.code s.stack_frame_sizes of + | NONE => (SOME (Rerr (Rabort Rtype_error)),s) + | SOME (args1,prog,ss) => + (case ret of + | NONE => + (if s.clock = 0 + then (SOME (Rerr(Rabort Rtimeout_error)), + flush_state T s) + else + (case evaluate (prog, call_env args1 ss (dec_clock s)) of + | (NONE,s) => (SOME (Rerr(Rabort Rtype_error)),s) + | (SOME res,s) => (SOME res,s))) + | SOME (dest,names) => + (case cut_env names s.locals of + | NONE => (SOME (Rerr(Rabort Rtype_error)),s) + | SOME env => + let s1 = call_env args1 ss (push_env env F (dec_clock s)) in + if s.clock = 0 then + (SOME (Rerr(Rabort Rtimeout_error)), + s1 with <| stack := [] ; locals := LN |>) + else + (case fix_clock s1 (evaluate (prog, s1)) of + | (SOME (Rval x),s2) => (NONE, set_var dest x s) + | (other,s2) => (other,s2))))))) /\ (evaluate (Call ret dest args handler,s) = case get_vars args s.locals of | NONE => (SOME (Rerr(Rabort Rtype_error)),s) @@ -1365,17 +1346,14 @@ Definition evaluate_def: | (NONE,s) => (SOME (Rerr(Rabort Rtype_error)),s) | res => res))))) Termination - simp [AppUnit_def] - \\ WF_REL_TAC `(inv_image (measure I LEX measure prog_size) - (\(xs,s). (s.clock,xs)))` + WF_REL_TAC `(inv_image (measure I LEX measure prog_size) + (\(xs,s). (s.clock,xs)))` \\ rpt strip_tac \\ simp[dec_clock_def] \\ imp_res_tac fix_clock_IMP \\ imp_res_tac (GSYM fix_clock_IMP) \\ FULL_SIMP_TAC (srw_ss()) [set_var_def,push_env_clock, call_env_def,LET_THM] - >- gvs [op_requires_names_def, cut_state_opt_def, AllCaseEqs(), cut_state_def] - >- fs [LESS_OR_EQ,dec_clock_def] - \\ decide_tac + \\ fs [dec_clock_def] End val evaluate_ind = theorem"evaluate_ind"; From 40e706bb150d3ebbed611554aca7073a549df524 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Tue, 19 Aug 2025 12:02:44 +0300 Subject: [PATCH 057/112] Fixed `dataProps` --- .../proofs/data_to_word_memoryProofScript.sml | 16 + .../backend/semantics/dataPropsScript.sml | 505 +++++++++++++----- compiler/backend/semantics/dataSemScript.sml | 8 +- 3 files changed, 393 insertions(+), 136 deletions(-) diff --git a/compiler/backend/proofs/data_to_word_memoryProofScript.sml b/compiler/backend/proofs/data_to_word_memoryProofScript.sml index 1293d3942b..7dca0464f8 100644 --- a/compiler/backend/proofs/data_to_word_memoryProofScript.sml +++ b/compiler/backend/proofs/data_to_word_memoryProofScript.sml @@ -6391,6 +6391,22 @@ Proof \\ fs [encode_header_def,AC STAR_ASSOC STAR_COMM,thunk_tag_bits_lemma] QED +Theorem memory_rel_Thunk_IMP: + memory_rel c be ts refs sp st m dm ((RefPtr bl nn,ptr)::vars) /\ + lookup nn refs = SOME (Thunk ev v) /\ + good_dimindex (:'a) ==> + ?ptr_w x:'a word. + ptr = Word ptr_w /\ + get_real_addr c st ptr_w = SOME x /\ + x IN dm /\ (x + bytes_in_word) IN dm /\ + (ev = Evaluated ⇒ (m x && 0x111100b) = n2w (8 + 6) * 2w) /\ + (ev = NotEvaluated ⇒ (m x && 0x111100b) = n2w (0 + 6) * 2w) /\ + memory_rel c be ts refs sp st m dm + ((v,m (x + bytes_in_word))::(RefPtr bl nn,ptr)::vars) +Proof + cheat +QED + Theorem word_list_exists_thm: (word_list_exists a 0 = emp) /\ (word_list_exists a (SUC n) = diff --git a/compiler/backend/semantics/dataPropsScript.sml b/compiler/backend/semantics/dataPropsScript.sml index 1c03b5ae88..d8f183a4fa 100644 --- a/compiler/backend/semantics/dataPropsScript.sml +++ b/compiler/backend/semantics/dataPropsScript.sml @@ -679,13 +679,6 @@ Proof \\ rveq \\ fs [] \\ every_case_tac \\ fs [] \\ rveq \\ fs [] \\ gvs [AllCaseEqs(), PULL_EXISTS] - >>~- ([`evaluate (AppUnit,_) = _`, - `dest_thunk _ _ = IsThunk NotEvaluated _`], - TRY ( - first_x_assum $ qspecl_then [`T`, `smx`, `safe`, `peak`] assume_tac - \\ gvs [] \\ metis_tac []) - \\ first_x_assum $ qspecl_then [`F`, `smx`, `safe`, `peak`] assume_tac - \\ gvs [] \\ metis_tac []) \\ TRY (simp[state_component_equality] \\ NO_TAC) \\ TRY (drule do_app_sm_safe_peak_swap \\ disch_then (qspecl_then [`smx`, `safe`, `peak`] strip_assume_tac) @@ -741,7 +734,56 @@ Proof >- (fs [evaluate_def] \\ every_case_tac \\ full_fs >> metis_tac []) - + (* Force *) + >- ( + reverse $ gvs [evaluate_def, flush_state_def, set_var_def, dec_clock_def, + call_env_def, push_env_def, AllCaseEqs()] + >- ( + IF_CASES_TAC \\ gvs [AllCaseEqs(), PULL_EXISTS] + \\ qmatch_goalsub_abbrev_tac ‘stack_max_fupd (K smnew)’ + \\ qmatch_goalsub_abbrev_tac ‘safe_for_space_fupd (K ssnew)’ + \\ qmatch_goalsub_abbrev_tac ‘peak_heap_length_fupd (K phlnew)’ + >- ( + first_x_assum + $ qspecl_then [‘T’, ‘smnew’,‘ssnew’,‘phlnew’] strip_assume_tac + \\ simp [set_var_def] \\ rw [state_component_equality] + \\ gvs [AllCaseEqs()] \\ metis_tac []) + >- ( + first_x_assum + $ qspecl_then [‘F’, ‘smnew’,‘ssnew’,‘phlnew’] strip_assume_tac + \\ simp [set_var_def] \\ rw [state_component_equality] + \\ gvs [AllCaseEqs()] \\ metis_tac [])) + >- ( + IF_CASES_TAC \\ gvs [AllCaseEqs(), PULL_EXISTS] + \\ qmatch_goalsub_abbrev_tac ‘stack_max_fupd (K smnew)’ + \\ qmatch_goalsub_abbrev_tac ‘safe_for_space_fupd (K ssnew)’ + \\ qmatch_goalsub_abbrev_tac ‘peak_heap_length_fupd (K phlnew)’ + >- ( + first_x_assum + $ qspecl_then [‘T’, ‘smnew’,‘ssnew’,‘phlnew’] strip_assume_tac + \\ simp [set_var_def] \\ rw [state_component_equality] + \\ gvs [pop_env_def, AllCaseEqs()]) + >- ( + first_x_assum + $ qspecl_then [‘F’, ‘smnew’,‘ssnew’,‘phlnew’] strip_assume_tac + \\ simp [set_var_def] \\ rw [state_component_equality] + \\ gvs [pop_env_def, AllCaseEqs()])) + >- ( + IF_CASES_TAC \\ gvs [AllCaseEqs(), PULL_EXISTS] + \\ qmatch_goalsub_abbrev_tac ‘stack_max_fupd (K smnew)’ + \\ qmatch_goalsub_abbrev_tac ‘safe_for_space_fupd (K ssnew)’ + \\ qmatch_goalsub_abbrev_tac ‘peak_heap_length_fupd (K phlnew)’ + >- ( + first_x_assum + $ qspecl_then [‘T’, ‘smnew’,‘ssnew’,‘phlnew’] strip_assume_tac + \\ simp [set_var_def] \\ rw [state_component_equality] + \\ gvs [pop_env_def, AllCaseEqs()]) + >- ( + first_x_assum + $ qspecl_then [‘F’, ‘smnew’,‘ssnew’,‘phlnew’] strip_assume_tac + \\ simp [set_var_def] \\ rw [state_component_equality] + \\ gvs [pop_env_def, AllCaseEqs()])) + \\ metis_tac []) (* Call *) (* to save the outer if to have minimised duplication trade-off then is to use explixit cases insteade ofIF_CASES_TAC *) @@ -923,44 +965,7 @@ Proof \\ every_case_tac \\ fs[state_component_equality,evaluate_safe_def,evaluate_peak_def]) (* Assign *) - >- (Cases_on `op = ThunkOp ForceThunk` - >- (simp [evaluate_def] - \\ gvs [op_requires_names_def, op_space_reset_def] - \\ IF_CASES_TAC - \\ gvs [AllCaseEqs(), cut_state_opt_def] - \\ ntac 2 (CASE_TAC \\ gvs []) - \\ Cases_on `get_vars args x'.locals` \\ gvs [] - \\ Cases_on `dest_thunk x'' x'.refs` \\ gvs [] - \\ Cases_on `t` \\ gvs [PULL_EXISTS] - >- ( - gvs [set_var_def, cut_state_def, cut_env_def, AllCaseEqs()] \\ rw [] - \\ gvs [state_component_equality]) - \\ IF_CASES_TAC \\ gvs [] - >- ( - gvs [flush_state_def] \\ rw [] - \\ gvs [cut_state_def, AllCaseEqs()] - \\ gvs [state_component_equality]) - \\ ntac 2 (CASE_TAC \\ gvs []) - >- ( - gvs [set_var_def, cut_state_def, cut_env_def, AllCaseEqs()] \\ rw [] - \\ first_x_assum drule - \\ disch_then $ qspec_then `lsz` assume_tac \\ gvs [] - \\ gvs [state_component_equality]) - \\ CASE_TAC \\ gvs [] - >- ( - CASE_TAC - \\ gvs [set_var_def, cut_state_def, cut_env_def, AllCaseEqs()] - \\ rw [] - \\ first_x_assum $ drule_then $ qspec_then `lsz` assume_tac - \\ gvs [] - \\ gvs [state_component_equality]) - \\ TOP_CASE_TAC \\ gvs [] - >- ( - gvs [jump_exc_def, AllCaseEqs(), PULL_EXISTS] - \\ gvs [cut_state_def, cut_env_def, AllCaseEqs()] \\ rw []) - \\ TOP_CASE_TAC \\ gvs [] - \\ gvs [cut_state_def, cut_env_def, AllCaseEqs()]) - \\ fs[evaluate_def] + >- (fs[evaluate_def] \\ every_case_tac \\ fs[set_var_def,cut_state_opt_with_const,do_app_with_stack_and_locals] \\ imp_res_tac do_app_err >> fs[] >> rpt var_eq_tac @@ -1034,6 +1039,98 @@ Proof \\ Cases_on `get_var n s.locals` \\ fs[] \\ Cases_on `isBool T x` \\ fs[get_var_def] \\ Cases_on `isBool F x` \\ fs[get_var_def]) + (* Force *) + >- ( + gvs [evaluate_def] + \\ TOP_CASE_TAC \\ gvs [] \\ rw [] + \\ gvs [AllCaseEqs(), flush_state_def, set_var_def, PULL_EXISTS] + >- simp [state_component_equality] + >- simp [state_component_equality] + >- simp [state_component_equality] + >- ( + rpt (PURE_CASE_TAC \\ gvs []) + \\ gvs [call_env_def,flush_state_def,dec_clock_def,jump_exc_def, + AllCaseEqs(), PULL_EXISTS] + \\ rw [] + \\ first_x_assum drule \\ strip_tac + \\ qmatch_goalsub_abbrev_tac `evaluate + (q', s with <|locals:= _; locals_size := _; stack := _; + stack_max := smnew; clock := _; + safe_for_space := ssnew |>)` + \\ gvs[] + \\ first_x_assum $ qspec_then ‘ss’ strip_assume_tac \\ gvs [] + \\ drule evaluate_smx_safe_peak_swap_aux \\ gvs [] + \\ disch_then $ qspecl_then [‘smnew’,‘ssnew’,‘s.peak_heap_length’] mp_tac + \\ rw [] \\ gvs [] + \\ simp [state_component_equality]) + >- simp [push_env_def, call_env_def, dec_clock_def, + state_component_equality] + >- ( + rw [] + >- gvs [call_env_def, push_env_def, dec_clock_def, pop_env_def, + AllCaseEqs()] + >- gvs [call_env_def, push_env_def, dec_clock_def, pop_env_def, + AllCaseEqs()] + \\ gvs [call_env_def, push_env_def, dec_clock_def] + \\ qmatch_goalsub_abbrev_tac ‘stack_max_fupd (K smnew)’ + \\ qmatch_goalsub_abbrev_tac ‘safe_for_space_fupd (K ssnew)’ + \\ qmatch_goalsub_abbrev_tac ‘stack_fupd (K new_stack)’ + \\ first_x_assum $ qspecl_then [‘new_stack’,‘ss’] mp_tac + \\ qunabbrev_tac ‘new_stack’ + \\ simp [] + \\ strip_tac + \\ drule evaluate_smx_safe_peak_swap_aux + \\ disch_then $ qspecl_then [‘smnew’,‘ssnew’,‘s.peak_heap_length’] mp_tac + \\ simp[] + \\ strip_tac \\ gvs [] + \\ gvs [pop_env_def, AllCaseEqs(), PULL_EXISTS] + \\ simp[state_component_equality]) + >- ( + rpt (TOP_CASE_TAC \\ gvs []) + >- ( + gvs [push_env_def, call_env_def, dec_clock_def] + \\ Ho_Rewrite.PURE_REWRITE_TAC [GSYM PULL_EXISTS, CONJ_ASSOC] + \\ simp [GSYM PULL_EXISTS, CONJ_ASSOC] + \\ conj_tac + >- ( + qmatch_asmsub_abbrev_tac ‘stack_max_fupd (K smnew)’ + \\ qmatch_asmsub_abbrev_tac ‘safe_for_space_fupd (K ssnew)’ + \\ gvs [pop_env_def, AllCaseEqs()] + \\ gvs [jump_exc_def, AllCaseEqs()] + \\ Cases_on ‘s.handler = LENGTH s.stack’ \\ gvs [LASTN_LEMMA] + \\ ‘s.handler < LENGTH s.stack’ by DECIDE_TAC \\ gvs [] + \\ simp [PULL_EXISTS] + \\ gvs [LASTN_CONS]) + \\ rpt strip_tac + \\ qmatch_goalsub_abbrev_tac `evaluate + (q', s with <|locals:= _; locals_size := _; stack := _; + stack_max := smnew; clock := _; + safe_for_space := ssnew |>)` + \\ first_x_assum $ qspecl_then [‘Env lsz env::xs’] mp_tac + \\ gvs [jump_exc_def, AllCaseEqs()] + \\ gvs [LASTN_CONS] + \\ disch_then $ qspec_then ‘ss’ strip_assume_tac + \\ drule evaluate_smx_safe_peak_swap_aux + \\ disch_then + $ qspecl_then [‘smnew’,‘ssnew’,‘s.peak_heap_length’] mp_tac + \\ simp[] + \\ strip_tac \\ gvs [] + \\ simp [state_component_equality]) + \\ ( + rw [] + \\ gvs [call_env_def, push_env_def, dec_clock_def] + \\ qmatch_goalsub_abbrev_tac ‘stack_max_fupd (K smnew)’ + \\ qmatch_goalsub_abbrev_tac ‘safe_for_space_fupd (K ssnew)’ + \\ qmatch_goalsub_abbrev_tac ‘stack_fupd (K (el1::_))’ + \\ last_x_assum $ qspec_then ‘el1::xs’ mp_tac + \\ qunabbrev_tac ‘el1’ + \\ simp [] \\ disch_then $ qspec_then ‘ss’ strip_assume_tac + \\ drule evaluate_smx_safe_peak_swap_aux + \\ disch_then + $ qspecl_then [‘smnew’,‘ssnew’,‘s.peak_heap_length’] mp_tac + \\ simp [] + \\ strip_tac \\ fs[] + \\ simp[state_component_equality]))) (* Call *) >- (fs[evaluate_def] \\ Cases_on `get_vars args s.locals` \\ fs[] @@ -1500,17 +1597,7 @@ Proof \\ fs[lookup_insert,state_component_equality] \\ METIS_TAC []) (* Assign *) - >- (Cases_on `op = ThunkOp ForceThunk` \\ gvs [] - >- (gvs [op_requires_names_def, op_space_reset_def] - \\ Cases_on `names_opt` \\ gvs [] - \\ gvs [cut_state_opt_def] - \\ gvs [cut_state_def] - \\ Cases_on `cut_env x s.locals` \\ gvs [] - \\ imp_res_tac locals_ok_cut_env \\ gvs [] - \\ gvs [AllCaseEqs()] - \\ rw [state_component_equality, locals_ok_def] - \\ metis_tac []) - \\ Cases_on `names_opt` \\ full_simp_tac(srw_ss())[] + >- (Cases_on `names_opt` \\ full_simp_tac(srw_ss())[] \\ Cases_on `op_requires_names op` \\ fs [cut_state_opt_def] >- (Cases_on `get_vars args s.locals` \\ fs [] \\ fs [cut_state_opt_def] @@ -1571,6 +1658,47 @@ Proof \\ IMP_RES_TAC locals_ok_get_var \\ full_simp_tac(srw_ss())[] \\ Cases_on `isBool T x` \\ full_simp_tac(srw_ss())[] \\ Cases_on `isBool F x` \\ full_simp_tac(srw_ss())[]) + (* Force *) + >- ( + Cases_on ‘get_var src s.locals’ \\ gvs [] + \\ Cases_on ‘dest_thunk x s.refs’ \\ gvs [] + \\ Cases_on ‘t’ \\ gvs [] + >- ( + imp_res_tac locals_ok_get_var \\ gvs [] + \\ Cases_on ‘ret’ \\ gvs [] + >- gvs [flush_state_def, state_component_equality, locals_ok_def] + \\ Cases_on ‘x'’ \\ gvs [set_var_def] + \\ gvs [state_component_equality, locals_ok_def] \\ rw [lookup_insert]) + \\ imp_res_tac locals_ok_get_var \\ gvs [] + \\ Cases_on ‘find_code (SOME loc) [x; v] s.code s.stack_frame_sizes’ + \\ gvs [] + \\ Cases_on ‘x'’ \\ gvs [] + \\ Cases_on ‘r’ \\ gvs [] + \\ Cases_on ‘ret’ \\ gvs [] + >- ( + Cases_on ‘s.clock = 0’ \\ gvs [] + >- gvs [flush_state_def, state_component_equality, locals_ok_def] + \\ `call_env q r' (dec_clock (s with locals := l)) = + call_env q r' (dec_clock s)` + by fs[state_component_equality, dec_clock_def, call_env_def, + flush_state_def] + \\ fs[] + \\ fs[call_env_def,locals_ok_def,lookup_def,fromList_def, flush_state_def] + \\ qexistsl [‘s2.locals’,‘s2.safe_for_space’,‘s2.peak_heap_length’, + ‘s2.stack_max’] + \\ gvs [locals_ok_refl] + \\ rw [state_component_equality]) + \\ Cases_on ‘x'’ \\ gvs [] + \\ Cases_on ‘cut_env r s.locals’ \\ gvs [] + \\ imp_res_tac locals_ok_cut_env \\ gvs [] + \\ `call_env q r' (push_env x' F (dec_clock (s with locals := l))) = + call_env q r' (push_env x' F (dec_clock s))` + by fs[state_component_equality,dec_clock_def,call_env_def,push_env_def, flush_state_def] + \\ Cases_on ‘s.clock = 0’ \\ gvs [] + >- rw [state_component_equality, push_env_def, dec_clock_def, locals_ok_def] + \\ qexistsl [‘s2.locals’,‘s2.safe_for_space’,‘s2.peak_heap_length’, + ‘s2.stack_max’] + \\ rw [state_component_equality, locals_ok_refl]) (* Call *) >- (Cases_on `get_vars args s.locals` \\ fs [] \\ IMP_RES_TAC locals_ok_get_vars \\ fs [] @@ -1773,20 +1901,12 @@ Proof >- (every_case_tac \\ fs[get_var_def,set_var_def] \\ srw_tac[][] >> fs[]) - >- (Cases_on `op = ThunkOp ForceThunk` \\ gvs [] - >- ( - gvs [op_requires_names_def, op_space_reset_def] - \\ Cases_on `names_opt` \\ gvs [cut_state_opt_def] - \\ Cases_on `cut_state x s` \\ gvs [] - \\ gvs [cut_state_def] - \\ Cases_on `cut_env x s.locals` \\ gvs [] - \\ gvs [AllCaseEqs(), set_var_def]) - \\ fs [do_app_aux_def,list_case_eq,option_case_eq,v_case_eq,cut_state_opt_def,cut_state_def - , bool_case_eq,ffiTheory.call_FFI_def,semanticPrimitivesTheory.result_case_eq - , with_fresh_ts_def,bvlSemTheory.ref_case_eq - , ffiTheory.ffi_result_case_eq,ffiTheory.oracle_result_case_eq - , semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq - , pair_case_eq,consume_space_def] + >- (fs [do_app_aux_def,list_case_eq,option_case_eq,v_case_eq,cut_state_opt_def,cut_state_def + , bool_case_eq,ffiTheory.call_FFI_def,semanticPrimitivesTheory.result_case_eq + , with_fresh_ts_def,bvlSemTheory.ref_case_eq + , ffiTheory.ffi_result_case_eq,ffiTheory.oracle_result_case_eq + , semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq + , pair_case_eq,consume_space_def] \\ rveq \\ fs [call_env_def,flush_state_def,do_app_with_clock,do_app_with_locals] \\ imp_res_tac do_app_const \\ fs [set_var_def,state_component_equality] \\ PairCases_on `y` \\ fs [] @@ -1821,6 +1941,11 @@ Proof \\ every_case_tac >> fs[] >> srw_tac[][] \\ rfs[] >> srw_tac[][]) >- (every_case_tac >> fs[] >> srw_tac[][]) + >- ( + gvs [AllCaseEqs(), PULL_EXISTS] + \\ gvs [flush_state_def, set_var_def, call_env_def, dec_clock_def, + push_env_def, pop_env_def] + \\ gvs [AllCaseEqs(), PULL_EXISTS]) >- (every_case_tac >> fs[] >> srw_tac[][] >> rfs[] \\ fsrw_tac[ARITH_ss][call_env_def,flush_state_def,dec_clock_def,push_env_def,pop_env_def,set_var_def,LET_THM] \\ TRY(first_x_assum(qspec_then`ck`mp_tac) >> simp[] @@ -1976,22 +2101,6 @@ Proof \\ srw_tac[][] >> fs[set_var_with_const,flush_state_def] \\ metis_tac[evaluate_io_events_mono,SND,PAIR,IS_PREFIX_TRANS ,set_var_const,set_var_with_const,with_clock_ffi]) - \\ TRY ( - rename1 `op = ThunkOp ForceThunk` - \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs [] >- ( - gvs [op_requires_names_def, op_space_reset_def] - \\ Cases_on `names_opt` \\ gvs [cut_state_opt_def, cut_state_def] - \\ Cases_on `cut_env x s.locals` \\ gvs [] - \\ every_case_tac >> fs[cut_state_opt_with_const] >> rfs[] - \\ imp_res_tac evaluate_io_events_mono >> rfs[] - \\ fs [] >> imp_res_tac jump_exc_IMP >> rw[jump_exc_NONE,flush_state_def] - \\ metis_tac[evaluate_io_events_mono,IS_PREFIX_TRANS,SND,PAIR]) - \\ every_case_tac >> fs[cut_state_opt_with_const] >> rfs[] - \\ rveq >> fs[] >> rveq >> fs[] - \\ fs [do_app_with_clock] - \\ TRY (PairCases_on `y`) >> fs [] - \\ fs [] >> imp_res_tac jump_exc_IMP >> rw[jump_exc_NONE,flush_state_def] - \\ NO_TAC) \\ rpt (pairarg_tac >> fs[]) \\ every_case_tac >> fs[cut_state_opt_with_const] >> rfs[] \\ rveq >> fs[] >> rveq >> fs[] @@ -2122,16 +2231,11 @@ Theorem evaluate_safe_for_space_mono: evaluate (prog,s) = (res,s1) /\ s1.safe_for_space ==> s.safe_for_space Proof recInduct evaluate_ind \\ fs [evaluate_def] \\ rw[] - \\ TRY ( - rename1 `op = ThunkOp ForceThunk` - \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs [] >- ( - gvs [op_requires_names_def, op_space_reset_def] - \\ Cases_on `names_opt` - \\ gvs [cut_state_opt_def, cut_state_def, AllCaseEqs()] - \\ gvs [set_var_def, flush_state_def]) - \\ gvs [cut_state_opt_def, cut_state_def, AllCaseEqs()] - \\ gvs [set_var_def, flush_state_def] - \\ imp_res_tac do_app_safe_for_space_mono \\ gvs []) + >>~- ([‘dest_thunk’], + gvs [AllCaseEqs()] + \\ gvs [flush_state_def, set_var_def, call_env_def, dec_clock_def, push_env_def, + pop_env_def] + \\ gvs [AllCaseEqs()]) \\ fs [CaseEq"option",cut_state_opt_def,CaseEq"result",pair_case_eq, cut_state_def,jump_exc_def,CaseEq"stack",CaseEq"list"] \\ fs [] \\ rveq \\ fs [set_var_def,call_env_def,flush_state_def,dec_clock_def,add_space_def] @@ -2173,14 +2277,7 @@ Proof >- trivial_tac >- (trivial_tac >> EVAL_TAC) (* Assign *) - >- ( - Cases_on `op = ThunkOp ForceThunk` >- ( - gvs [op_requires_names_def, op_space_reset_def, evaluate_def, - AllCaseEqs(), PULL_EXISTS] - \\ gvs [cut_state_opt_def, cut_state_def, AllCaseEqs()] - \\ TRY (last_x_assum $ qspec_then `limits'` assume_tac \\ gvs []) - \\ gvs [state_component_equality, set_var_def, flush_state_def]) - \\ fs [evaluate_def] + >- (fs [evaluate_def] \\ full_cases >> full_fs \\ fs [] \\ rfs[] \\ rveq \\ fs [] @@ -2211,6 +2308,55 @@ Proof \\ fs[] \\ rw[state_component_equality]) >- basic_tac + (* Force *) + >- ( + gvs [evaluate_def] + \\ Cases_on ‘get_var src s.locals’ \\ gvs [] + >- gvs [state_component_equality] + \\ Cases_on ‘dest_thunk x s.refs’ \\ gvs [] + >- gvs [state_component_equality] + >- gvs [state_component_equality] + \\ Cases_on ‘t’ \\ gvs [] + >- ( + Cases_on ‘ret’ \\ gvs [] + >- gvs [flush_state_def, state_component_equality] + \\ Cases_on ‘x'’ \\ gvs [set_var_def, state_component_equality]) + \\ Cases_on ‘find_code (SOME loc) [x; v] s.code s.stack_frame_sizes’ + \\ gvs [] + >- gvs [state_component_equality] + \\ Cases_on ‘x'’ \\ gvs [] + \\ Cases_on ‘r'’ \\ gvs [] + \\ Cases_on ‘ret’ \\ gvs [] + >- ( + Cases_on ‘s.clock = 0’ + >- gvs [flush_state_def, state_component_equality] + \\ gvs [dec_clock_def] + \\ Cases_on ‘evaluate (q',call_env q r'' (s with clock := s.clock − 1))’ + \\ gvs [call_env_def] + \\ Cases_on ‘q''’ \\ gvs [] + \\ first_x_assum $ qspec_then ‘limits'’ strip_assume_tac + \\ qpat_abbrev_tac ‘smnew = OPTION_MAP2 MAX _ _’ + \\ qpat_abbrev_tac ‘ssnew = (_ ∧ _)’ + \\ drule_then (qspecl_then [‘smnew’,‘ssnew’,‘s.peak_heap_length’] + strip_assume_tac) + evaluate_smx_safe_peak_swap + \\ gvs [state_component_equality]) + \\ Cases_on ‘x'’ \\ gvs [] + \\ Cases_on ‘cut_env r' s.locals’ \\ gvs [] + >- gvs [state_component_equality] + \\ Cases_on ‘s.clock = 0’ \\ gvs [] + >- gvs [push_env_def, call_env_def, dec_clock_def, state_component_equality] + \\ gvs [push_env_def, call_env_def, dec_clock_def] + \\ gvs [AllCaseEqs(), PULL_EXISTS] + \\ qmatch_goalsub_abbrev_tac ‘stack_max_fupd (K smnew)’ + \\ qmatch_goalsub_abbrev_tac ‘safe_for_space_fupd (K ssnew)’ + \\ res_tac + \\ first_x_assum $ qspec_then ‘limits'’ strip_assume_tac + \\ drule_then (qspecl_then [‘smnew’,‘ssnew’,‘s.peak_heap_length’] + strip_assume_tac) + evaluate_smx_safe_peak_swap \\ gvs [] + \\ gvs [set_var_def, pop_env_def, state_component_equality] + \\ gvs [AllCaseEqs()]) (* Call *) >> fs [evaluate_def] >> Cases_on `get_vars args s.locals` >> fs [] >> rveq >> fs [] @@ -2346,14 +2492,7 @@ Proof >- trivial_tac >- (trivial_tac >> EVAL_TAC >> simp[]) (* Assign *) - >- (Cases_on `op = ThunkOp ForceThunk` >- ( - gvs [op_requires_names_def, op_space_reset_def, evaluate_def, - cut_state_opt_def, cut_state_def, AllCaseEqs(), PULL_EXISTS] - \\ TRY ( - last_x_assum $ drule_then $ qspecl_then [`lsz`, `sfs`] assume_tac - \\ gvs []) - \\ gvs [state_component_equality, set_var_def, flush_state_def]) - \\ fs [evaluate_def] + >- (fs [evaluate_def] \\ full_cases >> full_fs \\ fs [] \\ rfs[] \\ rveq \\ fs [] @@ -2392,6 +2531,69 @@ Proof \\ fs[] \\ rw[state_component_equality]) >- basics_tac + (* Force *) + >- ( + gvs [evaluate_def] + \\ Cases_on ‘get_var src s.locals’ \\ gvs [] + >- gvs [state_component_equality] + \\ Cases_on ‘dest_thunk x s.refs’ \\ gvs [] + >- gvs [state_component_equality] + >- gvs [state_component_equality] + \\ Cases_on ‘t’ \\ gvs [] + >- ( + Cases_on ‘ret’ \\ gvs [] + >- gvs [flush_state_def, state_component_equality] + \\ Cases_on ‘x'’ \\ gvs [set_var_def, state_component_equality]) + \\ Cases_on ‘find_code (SOME loc) [x; v] s.code s.stack_frame_sizes’ + \\ gvs [] + >- ( + drule_then (qspec_then ‘sfs’ strip_assume_tac) find_code_upto_size + \\ rw [state_component_equality]) + \\ drule_then (qspec_then ‘sfs’ strip_assume_tac) find_code_upto_size + \\ Cases_on ‘x'’ \\ gvs [] + \\ Cases_on ‘r'’ \\ gvs [] + \\ Cases_on ‘ret’ \\ gvs [] + >- ( + Cases_on ‘s.clock = 0’ + >- ( + gvs [flush_state_def, state_component_equality] + \\ irule EVERY2_refl + \\ Cases \\ rw [stack_frame_size_rel_def]) + \\ gvs [dec_clock_def] + \\ Cases_on ‘evaluate (q',call_env q r'' (s with clock := s.clock − 1))’ + \\ gvs [call_env_def] + \\ Cases_on ‘q''’ \\ gvs [] + \\ res_tac + \\ first_x_assum $ qspecl_then [‘sfs’,‘other_size’] strip_assume_tac + \\ qpat_abbrev_tac ‘smnew = OPTION_MAP2 MAX _ _’ + \\ qpat_abbrev_tac ‘ssnew = (_ ∧ _)’ + \\ drule_then (qspecl_then [‘smnew’,‘ssnew’,‘s.peak_heap_length’] + strip_assume_tac) + evaluate_smx_safe_peak_swap + \\ gvs [] \\ rw [state_component_equality]) + \\ Cases_on ‘x'’ \\ gvs [] + \\ Cases_on ‘cut_env r' s.locals’ \\ gvs [] + >- gvs [state_component_equality] + \\ Cases_on ‘s.clock = 0’ \\ gvs [] + >- gvs [push_env_def, call_env_def, dec_clock_def, state_component_equality] + \\ gvs [push_env_def, call_env_def, dec_clock_def] + \\ fs [AllCaseEqs(), PULL_EXISTS] \\ rveq + \\ qmatch_goalsub_abbrev_tac ‘stack_max_fupd (K smnew)’ + \\ qmatch_goalsub_abbrev_tac ‘safe_for_space_fupd (K ssnew)’ + \\ qmatch_goalsub_abbrev_tac ‘stack_fupd (K (topstack::_))’ + \\ first_x_assum drule + \\ disch_then (mp_tac o CONV_RULE (RESORT_FORALL_CONV rev)) + \\ disch_then $ qspecl_then [‘xs’,‘topstack’] mp_tac + \\ simp[Abbr ‘topstack’, stack_frame_size_rel_def] + \\ disch_then $ qspecl_then [‘sfs’,‘other_size’] strip_assume_tac + \\ drule_then (qspecl_then [‘smnew’,‘ssnew’,‘s.peak_heap_length’] + strip_assume_tac) + evaluate_smx_safe_peak_swap \\ gvs [] + \\ simp [set_var_def] \\ rw [state_component_equality] + \\ gvs [pop_env_def, AllCaseEqs()] + \\ imp_res_tac LIST_REL_LENGTH \\ gvs [] + \\ fs [pop_env_def, CaseEq"list", CaseEq"stack"] \\ rveq \\ fs[] + \\ rfs [] \\ Cases_on ‘y’ \\ fs [stack_frame_size_rel_def]) (* Call *) >> fs [evaluate_def] >> Cases_on `get_vars args s.locals` >> fs [] >> rveq >> fs [] @@ -2588,10 +2790,6 @@ Proof >- ((* Move *) fs[evaluate_def,CaseEq "option",set_var_def] >> rveq >> rw[]) >- ((* Assign *) - Cases_on `op = ThunkOp ForceThunk` - >- gvs [op_requires_names_def, op_space_reset_def, evaluate_def, - cut_state_opt_def, cut_state_def, AllCaseEqs(), set_var_def, - flush_state_def] >> fs[evaluate_def,CaseEq"bool",CaseEq"option",CaseEq"result",CaseEq"prod", cut_state_opt_def,cut_state_def,set_var_def,get_vars_def] >> rveq >> fs[flush_state_def] >> @@ -2611,7 +2809,16 @@ Proof Cases_on `evaluate (c1,s)` >> res_tac >> fs[] >> metis_tac[option_le_trans]) >- ((* If *) - fs[evaluate_def,CaseEq"option",CaseEq"bool"]) >> + fs[evaluate_def,CaseEq"option",CaseEq"bool"]) + >- ((* Force *) + gvs [evaluate_def, AllCaseEqs(), PULL_EXISTS] + \\ gvs [flush_state_def, set_var_def, dec_clock_def, call_env_def, + push_env_def, pop_env_def, AllCaseEqs()] + \\ ( + (match_mp_tac option_le_trans \\ HINT_EXISTS_TAC \\ rw [] + \\ Cases_on ‘s.stack_max’ \\ rw [OPTION_MAP2_DEF, IS_SOME_EXISTS]) + ORELSE ( + Cases_on ‘s.stack_max’ \\ rw [OPTION_MAP2_DEF,IS_SOME_EXISTS]))) >> (* Call *) fs[evaluate_def,CaseEq"option",CaseEq"bool",CaseEq"prod",flush_state_def, CaseEq "result", CaseEq "error_result"] >> @@ -2785,16 +2992,6 @@ Proof fs[evaluate_def,CaseEq "option",set_var_def] >> rveq >> fs[get_var_def,cc_co_only_diff_def]) >- ((* Assign *) - Cases_on `op = ThunkOp ForceThunk` >- ( - gvs [op_requires_names_def, op_space_reset_def, evaluate_def, - cut_state_opt_def, cut_state_def, cut_env_def, - AllCaseEqs(), PULL_EXISTS] >> - TRY ( - last_x_assum - $ qspec_then `t with <|locals := insert 0 v LN; - clock := t.clock - 1|>` assume_tac >> - gvs []) >> - gvs [cc_co_only_diff_def, set_var_def, flush_state_def]) >> fs[evaluate_def] >> IF_CASES_TAC >- (fs[] >> rveq >> fs[]) >> @@ -2859,7 +3056,38 @@ Proof imp_res_tac evaluate_safe_for_space_mono >> res_tac >> fs[] >> rfs[] >> - fs[cc_co_only_diff_def]) >> + fs[cc_co_only_diff_def]) + >- ((* Force *) + qhdtm_assum ‘cc_co_only_diff’ + (strip_assume_tac o REWRITE_RULE [cc_co_only_diff_def]) + \\ gvs [evaluate_def] + \\ TOP_CASE_TAC \\ gvs [] + \\ TOP_CASE_TAC \\ gvs [CaseEq "prod"] + \\ TOP_CASE_TAC + >- ( + gvs [AllCaseEqs(), PULL_EXISTS, flush_state_def] + \\ gvs [cc_co_only_diff_def,state_component_equality,set_var_def]) + \\ gvs [CaseEq "prod"] + \\ ntac 4 (TOP_CASE_TAC \\ gvs []) + >- ( + gvs [AllCaseEqs(), PULL_EXISTS, flush_state_def] + >- gvs [cc_co_only_diff_def] + \\ first_x_assum (qspec_then ‘call_env q r' (dec_clock t)’ mp_tac) + \\ gvs [cc_co_only_diff_def, call_env_def, dec_clock_def] + \\ rw [] \\ gvs []) + \\ ntac 3 (TOP_CASE_TAC \\ gvs []) + >- gvs [cc_co_only_diff_def, call_env_def, push_env_def, dec_clock_def] + \\ gvs [CaseEq"prod"] + \\ drule_then (qspecl_then [‘x'’,‘r'’,‘F’,‘q’] strip_assume_tac) + cc_co_only_diff_call_env + \\ gvs [CaseEq "option", CaseEq "result", CaseEq "error_result"] + \\ gvs [set_var_def, PULL_EXISTS] + \\ imp_res_tac pop_env_safe_for_space \\ gvs [] + \\ res_tac \\ gvs [] + >- gvs [pop_env_def, cc_co_only_diff_def, AllCaseEqs()] + >- ( + drule_all_then strip_assume_tac pop_env_cc_co_only_diff + \\ goal_assum drule \\ fs[cc_co_only_diff_def])) >> (* Call *) qhdtm_assum `cc_co_only_diff` (strip_assume_tac o REWRITE_RULE[cc_co_only_diff_def]) >> fs[evaluate_def] >> @@ -2960,10 +3188,6 @@ Proof >- ((* Move *) fs[evaluate_def,CaseEq "option",set_var_def] >> rveq >> rw[]) >- ((* Assign *) - Cases_on `op = ThunkOp ForceThunk` >- ( - fs [op_requires_names_def, op_space_reset_def, cut_state_opt_def, - cut_state_def, evaluate_def, AllCaseEqs()] >> - gvs [set_var_def, flush_state_def]) >> fs[evaluate_def,CaseEq"bool",CaseEq"option",CaseEq"result",CaseEq"prod", cut_state_opt_def,cut_state_def,set_var_def,get_vars_def] >> rveq >> fs[flush_state_def] >> @@ -2985,7 +3209,20 @@ Proof metis_tac[option_le_trans,evaluate_safe_for_space_mono]) >- ((* If *) fs[evaluate_def,CaseEq"option",CaseEq"bool"] >> - rveq >> fs[]) >> + rveq >> fs[]) + >- ((* Force *) + ntac 3 (pop_assum mp_tac) + \\ rw [evaluate_def, AllCaseEqs(), flush_state_def, pop_env_def, + PULL_EXISTS] + \\ TRY(first_x_assum ACCEPT_TAC) + \\ TRY(first_x_assum drule \\ rpt (disch_then drule)) + \\ imp_res_tac evaluate_stack_limit + \\ imp_res_tac evaluate_option_le_stack_max + \\ imp_res_tac evaluate_safe_for_space_mono + \\ rpt (PRED_ASSUM is_forall kall_tac) + \\ gvs [call_env_def, dec_clock_def, push_env_def, set_var_def] + \\ imp_res_tac the_le_IMP_option_le + \\ gvs [option_le_max]) >> (* Call *) ntac 3 (pop_assum mp_tac) >> rw[evaluate_def,CaseEq"option",CaseEq"bool",CaseEq"prod",flush_state_def, diff --git a/compiler/backend/semantics/dataSemScript.sml b/compiler/backend/semantics/dataSemScript.sml index 4d8eba47c5..8a2f5cec6c 100644 --- a/compiler/backend/semantics/dataSemScript.sml +++ b/compiler/backend/semantics/dataSemScript.sml @@ -1304,8 +1304,12 @@ Definition evaluate_def: s1 with <| stack := [] ; locals := LN |>) else (case fix_clock s1 (evaluate (prog, s1)) of - | (SOME (Rval x),s2) => (NONE, set_var dest x s) - | (other,s2) => (other,s2))))))) /\ + | (SOME (Rval x),s2) => + (case pop_env s2 of + | NONE => (SOME (Rerr(Rabort Rtype_error)),s2) + | SOME s1 => (NONE, set_var dest x s1)) + | (NONE,s) => (SOME (Rerr(Rabort Rtype_error)),s) + | res => res)))))) /\ (evaluate (Call ret dest args handler,s) = case get_vars args s.locals of | NONE => (SOME (Rerr(Rabort Rtype_error)),s) From 5fdb36faf638f2aadc127fad435fe3855dc2583c Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Tue, 19 Aug 2025 11:06:30 +0200 Subject: [PATCH 058/112] Tidy up composition proof --- .../proofs/data_to_word_assignProofScript.sml | 34 +++++++++++-------- 1 file changed, 20 insertions(+), 14 deletions(-) diff --git a/compiler/backend/proofs/data_to_word_assignProofScript.sml b/compiler/backend/proofs/data_to_word_assignProofScript.sml index 6001d25e8b..5b041e55a5 100644 --- a/compiler/backend/proofs/data_to_word_assignProofScript.sml +++ b/compiler/backend/proofs/data_to_word_assignProofScript.sml @@ -14221,24 +14221,30 @@ Proof[exclude_simps = EXP_LE_LOG_SIMP EXP_LT_LOG_SIMP LE_EXP_LOG_SIMP \\ qexists_tac ‘x.space − LENGTH y2’ \\ fs [] QED +fun foldr1 f (x::xs) = foldr f x xs | foldr1 f [] = fail(); + +Triviality join_lemma = + METIS_PROVE [] “(b1 ⇒ x) ∧ (b2 ⇒ x) ⇒ (b1 ∨ b2 ⇒ x)”; + +Triviality imp_assign = + DB.match ["-"] “_ ==> ^assign_thm_goal” |> map (#1 o #2) + |> foldr1 (fn (x,y) => MATCH_MP join_lemma (CONJ x y)); + Theorem assign_thm: ^assign_thm_goal Proof strip_tac - \\ Cases_on `op = GlobOp AllocGlobal` \\ fs [] - THEN1 (fs [do_app] \\ every_case_tac \\ fs []) - \\ Cases_on `op = IntOp Greater` \\ fs [] - THEN1 (fs [do_app] \\ every_case_tac \\ fs []) - \\ Cases_on `op = IntOp GreaterEq` \\ fs [] - THEN1 (fs [do_app] \\ every_case_tac \\ fs []) - \\ map_every (fn th => - (Cases_on `^(th |> concl |> dest_imp |> #1)` THEN1 (fs [] - \\ match_mp_tac th \\ fs []))) - (DB.match ["-"] ``_ ==> ^assign_thm_goal`` |> map (#1 o #2)) - \\ fs [] \\ strip_tac - \\ Cases_on`op = MemOp (CopyByte T)` >- ( - fs[do_app_def,do_space_def,do_app_aux_def] - \\ every_case_tac \\ fs[] ) + \\ Cases_on `op = GlobOp AllocGlobal` + >- (fs [do_app] \\ every_case_tac \\ fs []) + \\ Cases_on `op = IntOp Greater` + >- (fs [do_app] \\ every_case_tac \\ fs []) + \\ Cases_on `op = IntOp GreaterEq` + >- (fs [do_app] \\ every_case_tac \\ fs []) + \\ Cases_on`op = MemOp (CopyByte T)` + >- (fs[do_app_def,do_space_def,do_app_aux_def] \\ every_case_tac \\ fs[]) + \\ irule imp_assign + \\ asm_rewrite_tac [] + \\ rpt $ first_assum $ irule_at Any \\ Cases_on ‘∃i. op = IntOp i’ >- (fs [] \\ fs [] \\ gvs [] \\ Cases_on ‘i’ \\ gvs []) \\ Cases_on ‘∃i. op = GlobOp i’ From 7cc1c1a27581db88df9d3daf0d258ada23249f75 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Tue, 19 Aug 2025 16:54:54 +0300 Subject: [PATCH 059/112] Fixed `data_live` and `data_space` --- compiler/backend/data_liveScript.sml | 6 + .../backend/proofs/data_liveProofScript.sml | 305 +++++++++++++----- .../backend/proofs/data_spaceProofScript.sml | 56 ++-- 3 files changed, 256 insertions(+), 111 deletions(-) diff --git a/compiler/backend/data_liveScript.sml b/compiler/backend/data_liveScript.sml index 8fd87fadf5..3962dffdcf 100644 --- a/compiler/backend/data_liveScript.sml +++ b/compiler/backend/data_liveScript.sml @@ -120,6 +120,12 @@ Definition compile_def: let (d3,l3) = compile c3 live in let (d2,l2) = compile c2 live in (If n d2 d3, insert n () (union l2 l3))) /\ + (compile (Force NONE loc src) live = + (Force NONE loc src,insert src () LN)) /\ + (compile (Force (SOME (n,names)) loc src) live = + let l1 = inter names (delete n live) in + let l2 = insert src () live in + (Force (SOME (n,l1)) loc src,l2)) /\ (compile (Call NONE dest vs handler) live = (Call NONE dest vs handler,list_to_num_set vs)) /\ (compile (Call (SOME (n,names)) dest vs NONE) live = diff --git a/compiler/backend/proofs/data_liveProofScript.sml b/compiler/backend/proofs/data_liveProofScript.sml index 7e5cac55c4..f1dc949d3e 100644 --- a/compiler/backend/proofs/data_liveProofScript.sml +++ b/compiler/backend/proofs/data_liveProofScript.sml @@ -196,87 +196,7 @@ Proof \\ Cases_on `lookup src t1.locals` \\ fs [set_var_def,lookup_insert]) THEN1 (* Assign *) - (Cases_on `op = ThunkOp ForceThunk` - >- (gvs [] - \\ Cases_on `names_opt` \\ gvs [] - >- (qpat_x_assum `_ = compile (Assign _ _ _ _) _` mp_tac - \\ rw [compile_def, is_pure_def] - \\ gvs [evaluate_def, dataLangTheory.op_requires_names_def, - dataLangTheory.op_space_reset_def]) - \\ qpat_x_assum `_ = compile (Assign _ _ _ _) _` mp_tac - \\ rw [compile_def] - \\ gvs [evaluate_def, dataLangTheory.op_requires_names_def, - dataLangTheory.op_space_reset_def, cut_state_opt_def, - cut_state_def, cut_env_def] - \\ `s.refs = t1.refs` by gvs [state_rel_def] \\ gvs [] - \\ Cases_on `domain x ⊆ domain s.locals` \\ gvs [] - \\ `domain x ∩ domain (list_insert args (delete dest l2)) ⊆ - domain t1.locals` by - (gvs [domain_inter, domain_list_insert, SUBSET_DEF, state_rel_def] - \\ gvs [domain_lookup] - \\ gvs [PULL_EXISTS, oneTheory.one] \\ metis_tac []) - \\ gvs [] - \\ Cases_on `get_vars args (inter s.locals x)` \\ gvs [] - \\ `get_vars - args - (inter t1.locals (inter x (list_insert args (delete dest l2)))) = - SOME x'` by - (qpat_x_assum `xx = SOME vs` (fn th => once_rewrite_tac [GSYM th]) - \\ match_mp_tac EVERY_get_vars - \\ gvs [EVERY_MEM, lookup_inter_alt, domain_inter, - domain_list_insert] - \\ rw [] \\ gvs [state_rel_def] - \\ first_x_assum (match_mp_tac o GSYM) - \\ gvs [domain_inter, domain_list_insert]) \\ gvs [] - \\ Cases_on `dest_thunk x' t1.refs` \\ gvs [] - \\ Cases_on `t` \\ gvs [] - >- (gvs [state_rel_def, set_var_def, lookup_insert] - \\ rpt strip_tac \\ rw [call_env_def, flush_state_def] - \\ gvs [domain_inter, domain_list_insert, domain_delete] - \\ gvs [lookup_inter_alt, domain_inter, domain_list_insert, - domain_delete]) - \\ `s.clock = t1.clock` by gvs [state_rel_def] \\ gvs [] - \\ Cases_on `t1.clock = 0` \\ gvs [] - >- gvs [state_rel_def, flush_state_def] - \\ Cases_on `evaluate (AppUnit, s with <|locals := insert 0 v LN; - clock := t1.clock − 1|>)` - \\ gvs [] - \\ qmatch_asmsub_abbrev_tac `state_rel s t1 xx` - \\ `state_rel - (s with <|locals := insert 0 v LN; clock := t1.clock - 1|>) - (t1 with <|locals := insert 0 v LN; clock := t1.clock - 1|>) - (insert 0 () LN)` - by gvs [state_rel_def] \\ gvs [] - \\ last_x_assum drule \\ rw [] - \\ pop_assum $ qspec_then `l2` assume_tac \\ gvs [] - \\ `∀s. (AppUnit,insert 0 () LN) = compile AppUnit s` by ( - rpt (pop_assum kall_tac) - \\ rw [] - \\ simp [AppUnit_def, compile_def, is_pure_def, list_insert_def, - list_to_num_set_def, lookup_insert] - \\ rpt (pairarg_tac \\ simp [] \\ gvs []) - \\ gvs [AllCaseEqs(), lookup_inter_alt, lookup_delete, lookup_insert] - \\ gvs [insert_compute, delete_compute, mk_BN_def, mk_BS_def, union_def, - inter_def]) - \\ Cases_on `q = SOME (Rerr (Rabort Rtype_error))` \\ gvs [] - \\ qpat_x_assum `_ ⇒ _` mp_tac - \\ impl_tac - >- (rw [] \\ gvs [jump_exc_def, AllCaseEqs(), state_rel_def]) - \\ rw [] \\ gvs [] - \\ gvs [AllCaseEqs(), PULL_EXISTS] - >- metis_tac [] - >- ( - first_x_assum (irule_at Any o GSYM) \\ gvs [PULL_EXISTS] - \\ qpat_x_assum `update_thunk _ _ _ = SOME _` mp_tac - \\ simp [oneline update_thunk_def] - \\ ntac 4 (TOP_CASE_TAC \\ gvs []) - \\ `r.refs = t2.refs` by gvs [state_rel_def] \\ gvs [] \\ rw [] - \\ gvs [set_var_def] - \\ unabbrev_all_tac \\ gvs [] - \\ gvs [state_rel_def, lookup_insert, lookup_inter_alt, - domain_list_insert]) - >- metis_tac []) - \\ Cases_on `names_opt` THEN1 + (Cases_on `names_opt` THEN1 (fs [compile_def] \\ Cases_on `lookup dest l2 = NONE ∧ is_pure op` \\ fs [] THEN1 @@ -402,6 +322,229 @@ Proof \\ MATCH_MP_TAC IMP_IMP \\ STRIP_TAC \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] \\ REPEAT STRIP_TAC \\ fs [] \\ fs [state_rel_def,domain_union])) + THEN1 ( (* Force *) + Cases_on ‘ret’ \\ gvs [evaluate_def, compile_def] + >- ( + Cases_on ‘get_var src s.locals’ \\ gvs [] + \\ ‘get_var src t1.locals = get_var src s.locals’ + by gvs [state_rel_def, get_var_def] \\ gvs [] + \\ ‘t1.refs = s.refs’ by gvs [state_rel_def] \\ gvs [] + \\ Cases_on ‘dest_thunk x s.refs’ \\ gvs [] + \\ Cases_on ‘t’ \\ gvs [] + >- gvs [state_rel_def, flush_state_def] + \\ ‘t1.code = s.code ∧ t1.stack_frame_sizes = s.stack_frame_sizes’ + by gvs [state_rel_def] \\ gvs [] + \\ Cases_on ‘find_code (SOME loc) [x; v] s.code s.stack_frame_sizes’ + \\ gvs [] + \\ Cases_on ‘x'’ \\ gvs [] + \\ Cases_on ‘r’ \\ gvs [] + \\ ‘t1.clock = s.clock’ by gvs [state_rel_def] \\ gvs [] + \\ Cases_on ‘s.clock = 0’ \\ gvs [] + >- gvs [state_rel_def, flush_state_def] + \\ Cases_on ‘evaluate (q',call_env q r' (dec_clock s))’ \\ gvs [] + \\ Cases_on ‘q''’ \\ gvs [] + \\ fs [] + \\ rename1 ‘evaluate (q',call_env q r' (dec_clock s)) = (SOME res2,s2)’ + \\ qspecl_then [‘q'’,‘call_env q r' (dec_clock s)’] mp_tac + evaluate_stack_swap + \\ fs [] + \\ `∃sm sfs. call_env q r' (dec_clock t1) = call_env q r' (dec_clock s) + with <| stack := t1.stack; stack_max := sm; safe_for_space := sfs; + peak_heap_length := t1.peak_heap_length |>` + by fs [call_env_def, dec_clock_def, state_rel_def, + state_component_equality, flush_state_def] + \\ Cases_on ‘res2’ \\ fs [] + >- ( + fs [call_env_def,dec_clock_def] \\ rpt strip_tac + \\ ‘LENGTH s.stack = LENGTH t1.stack’ by fs [state_rel_def] + \\ first_x_assum $ qspec_then ‘t1.stack’ mp_tac \\ fs [] + \\ strip_tac + \\ drule_all_then (qspecl_then + [‘sm’,‘sfs’,‘t1.peak_heap_length’] + strip_assume_tac) + evaluate_smx_safe_peak_swap + \\ fs [state_rel_def]) + \\ Cases_on ‘e’ \\ fs [] + >- ( + rpt strip_tac + \\ pop_assum $ qspec_then ‘t1.stack’ mp_tac + \\ qpat_x_assum ‘!x.bbb’ (mp_tac o GSYM) + \\ rename1 + ‘jump_exc (call_env q r' (dec_clock s)) = SOME s3’ + \\ qpat_x_assum ‘jump_exc (call_env q r' (dec_clock s)) = SOME s3’ + (mp_tac o GSYM) + \\ simp [call_env_def, dec_clock_def, Once jump_exc_def, LET_THM] + \\ ntac 2 CASE_TAC \\ strip_tac + \\ pop_assum (fn th => full_simp_tac std_ss [GSYM th]) + \\ asm_simp_tac (srw_ss()) [Once jump_exc_def] + \\ simp [Once jump_exc_def] + \\ ntac 2 CASE_TAC \\ fs [] \\ strip_tac + \\ `s.handler = t1.handler /\ + LENGTH s.stack = LENGTH t1.stack` by fs [state_rel_def] + \\ asm_simp_tac (srw_ss()) [Once jump_exc_def] + \\ rpt strip_tac \\ fs [] + \\ drule_all_then (qspecl_then + [‘sm’,‘sfs’,‘t1.peak_heap_length’] + strip_assume_tac) + evaluate_smx_safe_peak_swap + \\ fs[state_rel_def]) + \\ Cases_on ‘a’ \\ fs [] + \\ ( + fs [call_env_def,dec_clock_def] \\ rpt strip_tac + \\ ‘LENGTH s.stack = LENGTH t1.stack’ by fs [state_rel_def] + \\ first_x_assum $ qspec_then ‘t1.stack’ mp_tac \\ fs [] + \\ rw [state_rel_def] + \\ drule_all_then (qspecl_then + [‘sm’,‘sfs’,‘t1.peak_heap_length’] + strip_assume_tac) + evaluate_smx_safe_peak_swap + \\ fs[state_rel_def])) + \\ Cases_on ‘x’ + \\ rename1 ‘(d,l1) = compile (Force (SOME (v,names)) loc src) l2’ + \\ fs [compile_def, LET_DEF, evaluate_def] + \\ ‘get_var src t1.locals = get_var src s.locals’ + by gvs [state_rel_def, get_var_def] \\ gvs [] + \\ Cases_on ‘get_var src s.locals’ \\ gvs [] + \\ ‘t1.refs = s.refs’ by gvs [state_rel_def] \\ gvs [] + \\ Cases_on ‘dest_thunk x s.refs’ \\ gvs [] + \\ Cases_on ‘t’ \\ gvs [] + >- (gvs [state_rel_def, set_var_def] \\ rw [lookup_insert]) + \\ ‘t1.code = s.code ∧ t1.stack_frame_sizes = s.stack_frame_sizes’ + by gvs [state_rel_def] \\ gvs [] + \\ Cases_on ‘find_code (SOME loc) [x; v'] s.code s.stack_frame_sizes’ + \\ gvs [] + \\ Cases_on ‘x'’ \\ gvs [] + \\ Cases_on ‘r’ \\ gvs [] + \\ Cases_on ‘cut_env names s.locals’ \\ fs [] + \\ fs [cut_env_def] \\ reverse (srw_tac [] []) THEN1 + (pop_assum mp_tac \\ fs [] + \\ fs [SUBSET_DEF,domain_list_insert,domain_inter, + domain_delete,state_rel_def] + \\ rpt strip_tac \\ imp_res_tac get_vars_IMP_domain + \\ fs [domain_lookup] \\ metis_tac []) + \\ qabbrev_tac `t5 = call_env q r' (push_env + ((inter t1.locals (inter names (delete v l2)))) F (dec_clock t1))` + \\ `?sfsp smax lss. (call_env q r' (push_env ((inter s.locals names)) F + (dec_clock s)) + with <| locals_size := lss; + safe_for_space := sfsp; + peak_heap_length := t5.peak_heap_length; + stack := t5.stack; + stack_max := smax |>) = t5` by + (unabbrev_all_tac + \\ fs [call_env_def,push_env_def,dec_clock_def,state_rel_def, + state_component_equality]) \\ fs [] + \\ qabbrev_tac `t4 = + call_env q r' (push_env ((inter s.locals names)) F (dec_clock s))` + \\ ‘LENGTH t4.stack = LENGTH t5.stack’ by + (unabbrev_all_tac \\ fs [call_env_def, push_env_def, dec_clock_def] + \\ fs [state_rel_def]) + \\ qspecl_then [‘q'’,‘t4’] mp_tac evaluate_stack_swap + \\ Cases_on ‘s.clock = 0’ \\ fs [] + >- ( + gvs [state_rel_def, call_env_def] + \\ rpt (CASE_TAC \\ gvs []) + \\ fs [state_rel_def, call_env_def, state_component_equality]) + \\ Cases_on ‘evaluate (q',t4)’ \\ fs [] + \\ Cases_on ‘q''’ \\ fs [] \\ Cases_on ‘x'’ \\ fs [] + >- ( + rpt strip_tac + \\ first_x_assum $ qspec_then ‘t5.stack’ mp_tac \\ fs [] + \\ rpt strip_tac \\ fs [] \\ simp [pop_env_def] + \\ unabbrev_all_tac \\ fs [call_env_def, push_env_def] + \\ fs [pop_env_def] \\ fs [state_rel_def, set_var_def] + \\ qmatch_asmsub_abbrev_tac ‘evaluate (q',p) = (SOME _, ss)’ + \\ qmatch_goalsub_abbrev_tac ‘evaluate (q', ss')’ + \\ drule_all_then (qspecl_then [‘ss'.stack_max’ + ,‘ss'.safe_for_space’ + ,‘ss'.peak_heap_length’] assume_tac) + evaluate_smx_safe_peak_swap + \\ fs [] + \\ `ss' = p with <| stack_max := ss'.stack_max; + safe_for_space := ss'.safe_for_space; + peak_heap_length := ss'.peak_heap_length |>` + by (unabbrev_all_tac \\ rveq \\ fs [state_component_equality]) + \\ pop_assum (fn t => once_rewrite_tac [t]) \\ fs [] + \\ unabbrev_all_tac + \\ once_asm_rewrite_tac [] + \\ fs [] + \\ fs [lookup_insert, lookup_inter_alt, domain_list_insert, + domain_inter, domain_delete] \\ rpt strip_tac) + \\ Cases_on ‘e’ \\ fs [] + >- ( + rpt strip_tac + \\ pop_assum $ qspec_then ‘t5.stack’ mp_tac + \\ qpat_x_assum ‘!x.bbb’ (mp_tac o GSYM) + \\ rename1 ‘jump_exc t4 = SOME s3’ + \\ qpat_x_assum ‘jump_exc t4 = SOME s3’ (mp_tac o GSYM) + \\ unabbrev_all_tac + \\ simp_tac (srw_ss()) [call_env_def, push_env_def, dec_clock_def, + Once jump_exc_def] + \\ ntac 2 CASE_TAC \\ strip_tac + \\ ‘s.handler < LENGTH s.stack’ by + (Cases_on ‘s.handler = LENGTH s.stack’ + \\ fs [LASTN_LEMMA] \\ decide_tac) + \\ imp_res_tac LASTN_TL \\ fs [] + \\ asm_simp_tac (srw_ss()) [Once jump_exc_def] + \\ SIMP_TAC std_ss [Once jump_exc_def] + \\ ntac 2 CASE_TAC \\ fs [] \\ strip_tac + \\ `s.handler = t1.handler ∧ + LENGTH s.stack = LENGTH t1.stack` by fs [state_rel_def] + \\ asm_simp_tac (srw_ss()) [Once jump_exc_def] + \\ ‘t1.handler < LENGTH t1.stack’ by fs [] + \\ imp_res_tac LASTN_TL \\ fs [] \\ rpt strip_tac + \\ qabbrev_tac `env = Env t1.locals_size + ((inter t1.locals + (inter names (delete v l2))))` + \\ `t1 with <| locals := fromList q; stack := env::t1.stack; + clock := s.clock - 1|> = + s with <| safe_for_space := t1.safe_for_space; + peak_heap_length := t1.peak_heap_length; + locals_size := t1.locals_size; + stack_max := t1.stack_max; + locals := fromList q; stack := env::t1.stack; + clock := s.clock - 1|>` by + fs [state_component_equality, state_rel_def] + \\ qmatch_asmsub_abbrev_tac ‘evaluate (q',p) = (SOME _, ss)’ + \\ qmatch_goalsub_abbrev_tac ‘evaluate (q', ss')’ + \\ drule_all_then (qspecl_then [‘ss'.stack_max’ + ,‘ss'.safe_for_space’ + ,‘ss'.peak_heap_length’] assume_tac) + evaluate_smx_safe_peak_swap + \\ fs [] + \\ `ss' = p with <| stack_max := ss'.stack_max; + safe_for_space := ss'.safe_for_space; + peak_heap_length := ss'.peak_heap_length |>` + by ( + unabbrev_all_tac \\ rveq + \\ fs [state_component_equality, state_rel_def]) + \\ pop_assum (fn t => once_rewrite_tac [t]) + \\ unabbrev_all_tac + \\ once_asm_rewrite_tac [] + \\ fs [] + \\ rev_full_simp_tac std_ss [] + \\ fs [state_rel_def] \\ srw_tac [] [] \\ fs []) + \\ Cases_on ‘a’ \\ fs [] + \\ ( + rpt strip_tac + \\ first_x_assum (qspec_then ‘t5.stack’ mp_tac) \\ fs [] + \\ rpt strip_tac + \\ qmatch_asmsub_abbrev_tac ‘evaluate (q',p) = (SOME _, ss)’ + \\ qmatch_goalsub_abbrev_tac ‘evaluate (q', ss')’ + \\ drule_all_then (qspecl_then [‘ss'.stack_max’ + ,‘ss'.safe_for_space’ + ,‘ss'.peak_heap_length’] assume_tac) + evaluate_smx_safe_peak_swap + \\ fs [] + \\ `ss' = p with <| stack_max := ss'.stack_max; + safe_for_space := ss'.safe_for_space; + peak_heap_length := ss'.peak_heap_length |>` + by (unabbrev_all_tac \\ rveq \\ fs [state_component_equality] + \\ fs [call_env_def,push_env_def]) + \\ pop_assum (fn t => once_rewrite_tac [t]) + \\ unabbrev_all_tac + \\ once_asm_rewrite_tac [] + \\ fs [state_rel_def])) (* Call from here onwards *) \\ Cases_on `ret` \\ fs [evaluate_def,compile_def] THEN1 (* Call with ret = NONE *) diff --git a/compiler/backend/proofs/data_spaceProofScript.sml b/compiler/backend/proofs/data_spaceProofScript.sml index c5f534504c..db0b155eec 100644 --- a/compiler/backend/proofs/data_spaceProofScript.sml +++ b/compiler/backend/proofs/data_spaceProofScript.sml @@ -77,20 +77,7 @@ Proof \\ fs[lookup_insert,state_component_equality] \\ METIS_TAC []) THEN1 (* Assign *) - (Cases_on `op = ThunkOp ForceThunk` >- ( - gvs [op_requires_names_def, op_space_reset_def, cut_state_opt_def, - cut_state_def, AllCaseEqs(), PULL_EXISTS] - \\ imp_res_tac locals_ok_cut_env \\ gvs [] - \\ ( - (qmatch_goalsub_abbrev_tac `locals_ok ss.locals _`) - ORELSE (qabbrev_tac `ss = s`) - \\ qexistsl [`ss.locals`, `ss.safe_for_space`, `ss.peak_heap_length`, - `ss.stack_max`] \\ gvs [Abbr `ss`, state_component_equality] - \\ gvs [cut_env_def] - \\ `locals_ok s.locals s.locals` by gvs [locals_ok_refl] - \\ gvs [locals_ok_def] \\ rw [] - \\ gvs [lookup_inter_alt])) - \\ gvs [] + (gvs [] \\ BasicProvers.TOP_CASE_TAC \\ fs[cut_state_opt_def] \\ BasicProvers.CASE_TAC \\ fs[] THEN1 (Cases_on `get_vars args s.locals` @@ -226,22 +213,7 @@ Proof \\ MAP_EVERY Q.EXISTS_TAC [`w'`,`safe'''`,`peak'''`,`smx'''`] \\ IF_CASES_TAC \\ fs []) THEN1 (* Assign *) - (Cases_on `o' = ThunkOp ForceThunk` - >- (gvs[] - \\ Cases_on `o0` \\ gvs [] - >- gvs [evaluate_def, op_requires_names_def, op_space_reset_def] - \\ gvs [space_def, pMakeSpace_def] - \\ simp [Once evaluate_def] - \\ pairarg_tac \\ gvs [] - \\ Cases_on `q = SOME (Rerr (Rabort Rtype_error))` \\ gvs [] - \\ first_x_assum drule \\ strip_tac \\ gvs [] - \\ reverse $ Cases_on `q = NONE` \\ gvs [] - >- metis_tac [] - \\ last_x_assum drule \\ strip_tac \\ gvs [] - \\ Cases_on `res = NONE` \\ gvs [] - \\ drule_then (qspecl_then [`smx`, `safe`, `peak`] assume_tac) - evaluate_smx_safe_peak_swap \\ gvs [] - \\ metis_tac []) \\ gvs [] + (gvs [] \\ fs[pMakeSpace_def,space_def] \\ reverse (Cases_on `o0`) \\ fs[evaluate_def,cut_state_opt_def] THEN1 @@ -478,6 +450,30 @@ Proof (Cases_on `get_var n s.locals` \\ fs[] \\ IMP_RES_TAC locals_ok_get_var \\ fs[] \\ SRW_TAC [] [] \\ fs[]) + THEN1 (* Force *) + (gvs [AllCaseEqs(), PULL_EXISTS] + \\ imp_res_tac locals_ok_get_var \\ gvs [] + \\ imp_res_tac locals_ok_cut_env \\ gvs [] + >- gvs [flush_state_def, state_component_equality, locals_ok_def] + >- ( + gvs [set_var_def, state_component_equality, locals_ok_def] + \\ rw [lookup_insert]) + >- gvs [flush_state_def, state_component_equality, locals_ok_def] + >- ( + `call_env args1 ss (dec_clock (s with locals := l)) = + call_env args1 ss (dec_clock s)` + by gvs [state_component_equality, dec_clock_def, call_env_def] \\ gvs [] + \\ gvs [state_component_equality] + \\ metis_tac [locals_ok_refl]) + >- gvs [call_env_def, dec_clock_def, push_env_def, + state_component_equality, locals_ok_def] + >- ( + gvs [PULL_EXISTS] + \\ gvs [call_env_def, dec_clock_def, push_env_def, locals_ok_def] + \\ gvs [state_component_equality]) + >- ( + gvs [call_env_def, push_env_def, dec_clock_def, state_component_equality] + \\ metis_tac [locals_ok_refl])) THEN1 (* Call *) (Cases_on `get_vars args s.locals` \\ fs[] \\ IMP_RES_TAC locals_ok_get_vars \\ fs[] From 0d1f8099fe8092252115e0f022d80a47b256eb46 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Wed, 20 Aug 2025 11:51:56 +0300 Subject: [PATCH 060/112] Some progress on `bvi_to_data` --- .../backend/proofs/bvi_to_dataProofScript.sml | 267 +++++------------- compiler/backend/semantics/dataSemScript.sml | 55 ++-- 2 files changed, 99 insertions(+), 223 deletions(-) diff --git a/compiler/backend/proofs/bvi_to_dataProofScript.sml b/compiler/backend/proofs/bvi_to_dataProofScript.sml index fc06a4e5b7..0b4409ad02 100644 --- a/compiler/backend/proofs/bvi_to_dataProofScript.sml +++ b/compiler/backend/proofs/bvi_to_dataProofScript.sml @@ -648,41 +648,18 @@ Proof \\ rveq \\ fs [state_component_equality] QED -fun note_tac s g = (print ("compile_correct: " ^ s ^ "\n"); ALL_TAC g); - -Theorem evaluate_push_Seq: - evaluate ((if tail then Seq p (Return n) else p), t) = - evaluate (Seq p (if tail then Return n else Skip), t) +Theorem state_rel_dest_thunk: + state_rel s t ∧ + dest_thunk (data_to_bvi_v z) s.refs = IsThunk ev v ⇒ + ∃v'. dest_thunk z t.refs = IsThunk ev v' ∧ + data_to_bvi_v v' = v Proof - Cases_on `tail` \\ rw [evaluate_def] - \\ Cases_on `evaluate (p,t)` \\ rw [] + rw [] + \\ gvs [oneline bviSemTheory.dest_thunk_def, oneline dest_thunk_def, + state_rel_def, lookup_map, AllCaseEqs()] QED -Theorem AppUnit_eq: - evaluate (AppUnit,t) = - evaluate (Seq - (Seq - (Seq Skip (Assign 1 (BlockOp (ElemAt 1)) [0] NONE)) - (Assign 2 (BlockOp (EqualConst (Int 0))) [1] NONE)) - (If 2 - (Seq - (Seq - (Seq Skip (Assign 3 (BlockOp (Cons 0)) [] NONE)) - (Seq - Skip - (Seq Skip (Assign 4 (BlockOp (ElemAt 0)) [0] NONE)))) - (Call NONE NONE [3; 0; 4] NONE)) - (Seq - (Seq (Seq Skip (Assign 6 (BlockOp (Cons 0)) [] NONE)) Skip) - (Call NONE (SOME bvl_num_stubs) [6; 0] NONE))),t) -Proof - simp [AppUnit_def] - \\ simp [evaluate_def, dataLangTheory.op_requires_names_def, - dataLangTheory.op_space_reset_def, cut_state_opt_def, get_vars_def, - do_app_def, do_int_app_def, do_app_aux_def, do_space_def, - data_spaceTheory.op_space_req_def, - backend_commonTheory.small_enough_int_def] -QED +fun note_tac s g = (print ("compile_correct: " ^ s ^ "\n"); ALL_TAC g); Theorem compile_correct: ∀xs env s1 res s2 t1 n corr tail live. @@ -1003,169 +980,6 @@ Proof \\ IMP_RES_TAC get_vars_reverse \\ rveq \\ fs []) \\ gvs [] - \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs [] >- ( - gvs [evaluate_push_Seq] - \\ gvs [iAssign_def, dataLangTheory.op_requires_names_def, - dataLangTheory.op_space_reset_def] - \\ gvs [evaluate_def, cut_state_opt_def, cut_state_def, cut_env_def] - \\ gvs [oneline bviSemTheory.dest_thunk_def, dest_thunk_def, AllCaseEqs()] - \\ pairarg_tac \\ gvs [] - >- ( - `lookup ptr (map data_to_bvi_ref t2.refs) = - SOME (Thunk Evaluated v)`by gvs [state_rel_def] - \\ gvs [lookup_map, set_var_def] - \\ Cases_on `tail` \\ gvs [evaluate_def] - >- gvs [get_var_def, flush_state_def, data_to_bvi_result_def, - state_rel_def] - \\ rw [] - >- gvs [state_rel_def, set_var_def] - >- (unabbrev_all_tac \\ gvs [lookup_insert, lookup_inter]) - >- ( - unabbrev_all_tac - \\ gvs [var_corr_def, get_var_def, LIST_REL_EL_EQN, lookup_map, - lookup_insert, lookup_inter] - \\ gvs [lookup_inter_EQ, lookup_list_to_num_set, EL_MAP] - \\ rw [] - \\ res_tac \\ gvs [MEM_EL]) - >- ( - unabbrev_all_tac - \\ gvs [lookup_insert, AllCaseEqs(), lookup_inter] - \\ first_x_assum drule \\ rw []) - >- ( - unabbrev_all_tac - \\ gvs [lookup_insert] \\ rw [] - >- gvs [state_rel_def] - \\ gvs [lookup_inter, AllCaseEqs(), lookup_list_to_num_set] - \\ Cases_on `MEM k live` \\ gvs []) - >- gvs [jump_exc_def] - >- gvs [var_corr_def, get_var_def, get_vars_def, lookup_map, - state_rel_def, data_to_bvi_ref_def]) - >- ( - `lookup ptr (map data_to_bvi_ref t2.refs) = - SOME (Thunk NotEvaluated v)` by gvs [state_rel_def] - \\ gvs [lookup_map] - \\ `r.clock = t2.clock` by gvs [state_rel_def] - \\ gvs [flush_state_def, data_to_bvi_result_def, state_rel_def]) - >- ( - `lookup ptr (map data_to_bvi_ref t2.refs) = - SOME (Thunk NotEvaluated v)`by gvs [state_rel_def] - \\ gvs [lookup_map] - \\ `r.clock = t2.clock` by gvs [state_rel_def] \\ gvs [PULL_EXISTS] - \\ `state_rel (dec_clock 1 r) - (t2 with <| - locals := insert 0 w' LN; - clock := t2.clock - 1 |>)` - by gvs [bviSemTheory.dec_clock_def, dec_clock_def, state_rel_def] - \\ last_x_assum $ drule_at (Pat `state_rel _ _`) \\ gvs [] - \\ disch_then $ qspecl_then [`1`, `[0]`, `T`, `[]`] mp_tac - \\ impl_tac - >- gvs [var_corr_def, get_var_def, dec_clock_def, lookup_map, - lookup_insert] - \\ strip_tac \\ gvs [] - \\ Cases_on `pres` \\ gvs [] - \\ gvs [data_to_bvi_v_def, SF ETA_ss] - \\ gvs [bviSemTheory.AppUnit_def, compile_def] - \\ gvs [any_el_def, dataLangTheory.mk_ticks_def] - \\ gvs [iAssign_def, dataLangTheory.op_requires_names_def, - dataLangTheory.op_space_reset_def, - data_spaceTheory.op_space_req_def] - \\ gvs [AppUnit_eq, PULL_EXISTS] - \\ reverse $ Cases_on `x` \\ gvs [] - >- (Cases_on `e` \\ gvs [data_to_bvi_result_def]) - \\ imp_res_tac evaluate_locals_LN \\ gvs [] - \\ qpat_x_assum `evaluate _ = (SOME x,_)` kall_tac - \\ qpat_x_assum `update_thunk _ _ _ = SOME _` mp_tac - \\ simp [bviSemTheory.update_thunk_def] \\ TOP_CASE_TAC - \\ simp [bviSemTheory.store_thunk_def] - \\ ntac 3 (TOP_CASE_TAC \\ simp []) \\ strip_tac \\ gvs [] - \\ gvs [update_thunk_def] - \\ `dest_thunk [a] t2'.refs = NotThunk` by ( - gvs [state_rel_def, oneline bviSemTheory.dest_thunk_def, - oneline dest_thunk_def] - \\ CASE_TAC \\ gvs [data_to_bvi_v_def] - \\ CASE_TAC \\ gvs [] - \\ gvs [lookup_map] - \\ ntac 2 (CASE_TAC \\ gvs []) - \\ gvs [data_to_bvi_ref_def]) \\ gvs [] - \\ gvs [store_thunk_def] - \\ `∀n. FLOOKUP s''.refs n = lookup n (map data_to_bvi_ref t2'.refs)` - by gvs [state_rel_def] \\ gvs [] - \\ pop_assum $ qspec_then `ptr` assume_tac \\ gvs [] - \\ gvs [lookup_map] - \\ Cases_on `tail` \\ gvs [evaluate_def] - >- ( - gvs [get_var_def, set_var_def, state_rel_def, flush_state_def, - lookup_map, lookup_insert, FLOOKUP_UPDATE, - data_to_bvi_result_def] - \\ rw [] \\ gvs [data_to_bvi_ref_def]) - \\ gvs [lookup_insert, map_insert, var_corr_def, get_var_def, - set_var_def] - \\ conj_tac - >- ( - gvs [state_rel_def, lookup_map, lookup_insert] - \\ rw [] - >- gvs [data_to_bvi_ref_def, FLOOKUP_DEF] - \\ gvs [FLOOKUP_UPDATE]) - \\ conj_tac - >- ( - rw [] - \\ unabbrev_all_tac \\ gvs [] - \\ gvs [lookup_inter]) - \\ conj_tac - >- ( - `¬MEM n1 corr` by ( - qpat_x_assum `∀k. n1 ≤ k ⇒ _` assume_tac - \\ qpat_x_assum `LIST_REL _ corr _` assume_tac - \\ CCONTR_TAC \\ gvs [] - \\ gvs [MEM_EL, LIST_REL_EL_EQN] - \\ first_x_assum drule \\ gvs [lookup_map, EL_MAP]) - \\ gvs [LIST_REL_EL_EQN, MEM_EL] - \\ rw [] - \\ unabbrev_all_tac - \\ gvs [lookup_map, lookup_inter_EQ, lookup_list_to_num_set, EL_MAP, - MEM_EL] - \\ metis_tac []) - \\ conj_tac - >- ( - rw [] - \\ unabbrev_all_tac - \\ gvs [lookup_inter_alt] - \\ res_tac - \\ fs []) - \\ conj_tac - >- ( - rw [] - \\ unabbrev_all_tac - \\ gvs [lookup_inter_EQ, lookup_list_to_num_set, EL_MAP, MEM_EL] - \\ metis_tac []) - \\ gvs [jump_exc_def] - \\ rpt (CASE_TAC \\ gvs [])) - >- ( - `lookup ptr (map data_to_bvi_ref t2.refs) = - SOME (Thunk NotEvaluated v)` by gvs [state_rel_def] - \\ gvs [lookup_map] - \\ `r.clock = t2.clock` by gvs [state_rel_def] \\ gvs [PULL_EXISTS] - \\ `state_rel (dec_clock 1 r) - (t2 with <| - locals := insert 0 w' LN; - clock := t2.clock - 1 |>)` - by gvs [bviSemTheory.dec_clock_def, dec_clock_def, state_rel_def] - \\ last_x_assum $ drule_at (Pat `state_rel _ _`) \\ gvs [] - \\ disch_then $ qspecl_then [`1`, `[0]`, `T`, `[]`] mp_tac - \\ impl_tac - >- (gvs [var_corr_def, get_var_def, dec_clock_def, lookup_map, - lookup_insert] - \\ rw [] \\ gvs [jump_exc_def, AllCaseEqs()]) - \\ gvs [] \\ strip_tac \\ gvs [] - \\ Cases_on `pres` \\ gvs [] - \\ Cases_on `x` \\ gvs [data_to_bvi_result_def] - \\ gvs [bviSemTheory.AppUnit_def, compile_def] - \\ gvs [any_el_def, dataLangTheory.mk_ticks_def] - \\ gvs [iAssign_def, dataLangTheory.op_requires_names_def, - dataLangTheory.op_space_reset_def, - data_spaceTheory.op_space_req_def] - \\ gvs [AppUnit_eq, PULL_EXISTS] - \\ metis_tac [])) \\ reverse(Cases_on `do_app op (MAP data_to_bvi_v (REVERSE z')) r`) \\ full_simp_tac(srw_ss())[] >- ( imp_res_tac bviPropsTheory.do_app_err >> full_simp_tac(srw_ss())[] >> rveq >> IF_CASES_TAC >> @@ -1394,6 +1208,9 @@ Proof \\ fs[jump_exc_def] \\ TOP_CASE_TAC \\ fs[] \\ TOP_CASE_TAC \\ fs[]) + \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs [] + >- gvs [bviSemTheory.do_app_def, bvlSemTheory.do_app_def, + bviSemTheory.do_app_aux_def, AllCaseEqs()] \\ fs [] \\ fs[bviSemTheory.state_component_equality] \\ rveq \\ Cases_on `op_requires_names op` @@ -1584,6 +1401,66 @@ Proof \\ FULL_SIMP_TAC (srw_ss()) [var_corr_def,dataSemTheory.dec_clock_def, get_var_def,state_rel_def,bviSemTheory.dec_clock_def, jump_exc_NONE]) + >- ((* Force *) + gvs [evaluate_def, AllCaseEqs(), PULL_EXISTS] + >- ( + gvs [any_el_ALT, var_corr_def, LIST_REL_EL_EQN] + \\ last_x_assum $ drule_then assume_tac \\ gvs [] + \\ gvs [get_var_def, lookup_map] + \\ drule_all_then assume_tac state_rel_dest_thunk \\ gvs [] + \\ Cases_on `tail` \\ gvs [] + >- gvs [state_rel_def, flush_state_def] + \\ gvs [state_rel_def, set_var_def, lookup_insert, lookup_map] \\ rw [] + >- cheat + >- cheat + >- cheat + >- gvs [jump_exc_def]) + >- ( + gvs [any_el_ALT, var_corr_def, LIST_REL_EL_EQN] + \\ last_x_assum $ drule_then assume_tac \\ gvs [] + \\ gvs [get_var_def, lookup_map] + \\ drule_all_then assume_tac state_rel_dest_thunk \\ gvs [] + \\ `t1.clock = s.clock` by gvs [state_rel_def] \\ gvs [] + \\ gvs [state_rel_def, flush_state_def]) + \\ gvs [any_el_ALT, var_corr_def, LIST_REL_EL_EQN] + \\ first_x_assum $ drule_then assume_tac \\ gvs [] + \\ gvs [get_var_def, lookup_map] + \\ drule_all_then assume_tac state_rel_dest_thunk \\ gvs [] + \\ `t1.clock = s.clock` by gvs [state_rel_def] \\ gvs [] + \\ `find_code (SOME force_loc) (MAP data_to_bvi_v [z;v']) s.code = + SOME (args,exp)` by gvs [] + \\ drule_all find_code_lemma \\ rw [] \\ gvs [] + \\ Cases_on `tail` \\ gvs [PULL_EXISTS] + >- ( + gvs [compile_exp_def] + \\ last_x_assum + $ qspecl_then [`call_env args' ss (dec_clock t1)`, `LENGTH args'`, + `COUNT_LIST (LENGTH args')`, `T`, `[]`] mp_tac + \\ gvs [] \\ impl_tac + >- ( + rw [] + >- gvs [COUNT_LIST_GENLIST] + >- gvs [COUNT_LIST_GENLIST, EL_MAP, dec_clock_def, call_env_def, + lookup_fromList] + >- gvs [call_env_def, lookup_fromList, dec_clock_def] + >- gvs [dec_clock_def, bviSemTheory.dec_clock_def, state_rel_def, + call_env_def] + >- gvs [jump_exc_def, dec_clock_def, call_env_def, AllCaseEqs()]) + \\ rw [] \\ gvs [] + \\ Cases_on `pres` \\ gvs [] + \\ Cases_on `x` \\ gvs [dec_clock_def] + >- ( + qspecl_then [`prog`,`call_env args' ss (t1 with clock := s.clock - 1)`] + assume_tac optimise_correct \\ gvs [] + \\ gvs [state_rel_def, call_env_def]) + \\ qspecl_then [`prog`,`call_env args' ss (t1 with clock := s.clock - 1)`] + assume_tac optimise_correct \\ gvs [] + \\ Cases_on `e` \\ gvs [] + >- ( + gvs [state_rel_def, jump_exc_def, call_env_def, AllCaseEqs()] + \\ qexists `ls` \\ gvs [state_component_equality]) + \\ gvs [state_rel_def]) + cheat) (* Call *) \\ note_tac "Call" \\ Cases_on `handler` diff --git a/compiler/backend/semantics/dataSemScript.sml b/compiler/backend/semantics/dataSemScript.sml index 8a2f5cec6c..78adfdf044 100644 --- a/compiler/backend/semantics/dataSemScript.sml +++ b/compiler/backend/semantics/dataSemScript.sml @@ -1282,34 +1282,33 @@ Definition evaluate_def: | NONE => (SOME (Rval v),flush_state F s) | SOME (dest,names) => (NONE, set_var dest v s)) | IsThunk NotEvaluated f => - (case find_code (SOME loc) [thunk_v; f] s.code s.stack_frame_sizes of - | NONE => (SOME (Rerr (Rabort Rtype_error)),s) - | SOME (args1,prog,ss) => - (case ret of - | NONE => - (if s.clock = 0 - then (SOME (Rerr(Rabort Rtimeout_error)), - flush_state T s) - else - (case evaluate (prog, call_env args1 ss (dec_clock s)) of - | (NONE,s) => (SOME (Rerr(Rabort Rtype_error)),s) - | (SOME res,s) => (SOME res,s))) - | SOME (dest,names) => - (case cut_env names s.locals of - | NONE => (SOME (Rerr(Rabort Rtype_error)),s) - | SOME env => - let s1 = call_env args1 ss (push_env env F (dec_clock s)) in - if s.clock = 0 then - (SOME (Rerr(Rabort Rtimeout_error)), - s1 with <| stack := [] ; locals := LN |>) - else - (case fix_clock s1 (evaluate (prog, s1)) of - | (SOME (Rval x),s2) => - (case pop_env s2 of - | NONE => (SOME (Rerr(Rabort Rtype_error)),s2) - | SOME s1 => (NONE, set_var dest x s1)) - | (NONE,s) => (SOME (Rerr(Rabort Rtype_error)),s) - | res => res)))))) /\ + (if s.clock = 0 then + (SOME (Rerr(Rabort Rtimeout_error)), flush_state T s) + else + (case find_code (SOME loc) [thunk_v; f] s.code s.stack_frame_sizes of + | NONE => (SOME (Rerr (Rabort Rtype_error)),s) + | SOME (args1,prog,ss) => + (case ret of + | NONE => + (case evaluate (prog, call_env args1 ss (dec_clock s)) of + | (NONE,s) => (SOME (Rerr(Rabort Rtype_error)),s) + | (SOME res,s) => (SOME res,s)) + | SOME (dest,names) => + (case cut_env names s.locals of + | NONE => (SOME (Rerr(Rabort Rtype_error)),s) + | SOME env => + let s1 = call_env args1 ss (push_env env F (dec_clock s)) in + if s.clock = 0 then + (SOME (Rerr(Rabort Rtimeout_error)), + s1 with <| stack := [] ; locals := LN |>) + else + (case fix_clock s1 (evaluate (prog, s1)) of + | (SOME (Rval x),s2) => + (case pop_env s2 of + | NONE => (SOME (Rerr(Rabort Rtype_error)),s2) + | SOME s1 => (NONE, set_var dest x s1)) + | (NONE,s) => (SOME (Rerr(Rabort Rtype_error)),s) + | res => res))))))) /\ (evaluate (Call ret dest args handler,s) = case get_vars args s.locals of | NONE => (SOME (Rerr(Rabort Rtype_error)),s) From 2d856b0ae8076fc4f953e7d64d9398efb3fdb8dd Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Wed, 20 Aug 2025 15:52:13 +0300 Subject: [PATCH 061/112] Fix `bvi_to_data`. TODO cleanup --- compiler/backend/data_liveScript.sml | 2 +- .../backend/proofs/bvi_to_dataProofScript.sml | 101 ++++++++++++++++-- .../backend/proofs/data_liveProofScript.sml | 27 ++--- compiler/backend/semantics/dataSemScript.sml | 5 +- 4 files changed, 112 insertions(+), 23 deletions(-) diff --git a/compiler/backend/data_liveScript.sml b/compiler/backend/data_liveScript.sml index 3962dffdcf..9a95778008 100644 --- a/compiler/backend/data_liveScript.sml +++ b/compiler/backend/data_liveScript.sml @@ -124,7 +124,7 @@ Definition compile_def: (Force NONE loc src,insert src () LN)) /\ (compile (Force (SOME (n,names)) loc src) live = let l1 = inter names (delete n live) in - let l2 = insert src () live in + let l2 = insert src () l1 in (Force (SOME (n,l1)) loc src,l2)) /\ (compile (Call NONE dest vs handler) live = (Call NONE dest vs handler,list_to_num_set vs)) /\ diff --git a/compiler/backend/proofs/bvi_to_dataProofScript.sml b/compiler/backend/proofs/bvi_to_dataProofScript.sml index 0b4409ad02..710ceafd9a 100644 --- a/compiler/backend/proofs/bvi_to_dataProofScript.sml +++ b/compiler/backend/proofs/bvi_to_dataProofScript.sml @@ -1405,15 +1405,35 @@ Proof gvs [evaluate_def, AllCaseEqs(), PULL_EXISTS] >- ( gvs [any_el_ALT, var_corr_def, LIST_REL_EL_EQN] - \\ last_x_assum $ drule_then assume_tac \\ gvs [] - \\ gvs [get_var_def, lookup_map] + \\ last_assum $ drule_then assume_tac \\ fs [] + \\ fs [get_var_def, lookup_map] \\ gvs [] \\ drule_all_then assume_tac state_rel_dest_thunk \\ gvs [] \\ Cases_on `tail` \\ gvs [] >- gvs [state_rel_def, flush_state_def] - \\ gvs [state_rel_def, set_var_def, lookup_insert, lookup_map] \\ rw [] - >- cheat - >- cheat - >- cheat + \\ gvs [cut_env_def] + \\ `domain (list_to_num_set (live ++ corr)) ⊆ domain t1.locals` by ( + gvs [SUBSET_DEF, domain_lookup, lookup_list_to_num_set] + \\ rw [] + >- ( + gvs [EVERY_EL, MEM_EL] + \\ first_x_assum drule \\ rw [] + \\ Cases_on `lookup (EL n'' live) t1.locals` \\ gvs []) + >- ( + gvs [MEM_EL] + \\ first_x_assum drule \\ rw [] + \\ simp [SF SFY_ss])) + \\ gvs [set_var_def, state_rel_def, lookup_insert, lookup_inter_alt, + domain_list_to_num_set, lookup_map] \\ rw [] + >- (last_x_assum drule \\ rw []) + >- gvs [MEM_EL] + >- ( + gvs [SUBSET_DEF, domain_list_to_num_set] + \\ rpt (first_x_assum $ qspec_then `k` assume_tac \\ gvs [])) + >- ( + gvs [SUBSET_DEF, domain_list_to_num_set] + \\ rpt (first_x_assum $ qspec_then `k` assume_tac \\ gvs [])) + >- gvs [MEM_EL] + >- gvs [MEM_EL] >- gvs [jump_exc_def]) >- ( gvs [any_el_ALT, var_corr_def, LIST_REL_EL_EQN] @@ -1423,8 +1443,8 @@ Proof \\ `t1.clock = s.clock` by gvs [state_rel_def] \\ gvs [] \\ gvs [state_rel_def, flush_state_def]) \\ gvs [any_el_ALT, var_corr_def, LIST_REL_EL_EQN] - \\ first_x_assum $ drule_then assume_tac \\ gvs [] - \\ gvs [get_var_def, lookup_map] + \\ first_assum $ drule_then assume_tac \\ fs [] + \\ fs [get_var_def, lookup_map] \\ gvs [] \\ drule_all_then assume_tac state_rel_dest_thunk \\ gvs [] \\ `t1.clock = s.clock` by gvs [state_rel_def] \\ gvs [] \\ `find_code (SOME force_loc) (MAP data_to_bvi_v [z;v']) s.code = @@ -1460,7 +1480,70 @@ Proof gvs [state_rel_def, jump_exc_def, call_env_def, AllCaseEqs()] \\ qexists `ls` \\ gvs [state_component_equality]) \\ gvs [state_rel_def]) - cheat) + \\ last_x_assum $ qspecl_then [ + `call_env args' ss (push_env (inter t1.locals + (list_to_num_set (live ++ corr))) F (dec_clock t1))`, + `LENGTH args'`, `COUNT_LIST (LENGTH args')`, `T`, `[]`] mp_tac + \\ gvs [COUNT_LIST_GENLIST, dec_clock_def, bviSemTheory.dec_clock_def] + \\ impl_tac + >- ( + rw [] + >- gvs [call_env_def, push_env_def, lookup_fromList, EL_MAP] + >- gvs [call_env_def, push_env_def, lookup_fromList] + >- gvs [call_env_def, push_env_def, state_rel_def] + >- gvs [call_env_def, push_env_def, jump_exc_def, AllCaseEqs(), LASTN_TL]) + \\ rw [] \\ gvs [] + \\ Cases_on `pres` \\ gvs [PULL_EXISTS] + \\ `domain (list_to_num_set (live ++ corr)) ⊆ domain t1.locals` by ( + gvs [SUBSET_DEF, domain_lookup, lookup_list_to_num_set] + \\ rw [] + >- ( + gvs [EVERY_EL, MEM_EL] + \\ first_x_assum drule \\ rw [] + \\ Cases_on `lookup (EL n'' live) t1.locals` \\ gvs []) + >- ( + gvs [MEM_EL] + \\ first_x_assum drule \\ rw [] + \\ simp [SF SFY_ss])) + \\ gvs [cut_env_def, PULL_EXISTS, compile_exp_def, COUNT_LIST_GENLIST] + \\ qspecl_then [`prog`, + `call_env args' ss (push_env (inter t1.locals (list_to_num_set (live ++ corr))) + F (t1 with clock := s.clock − 1))`] + assume_tac optimise_correct \\ gvs [] + \\ reverse $ Cases_on `x` \\ gvs [] + >- ( + Cases_on `e` \\ gvs [] + >- ( + gvs [state_rel_def, jump_exc_def, call_env_def, push_env_def, + LASTN_TL, AllCaseEqs()] + \\ qexists `ls` \\ gvs [state_component_equality]) + \\ gvs [state_rel_def]) + \\ `pop_env (t2 with <| locals_size := ls'; + stack_max := smx; + safe_for_space := safe; + peak_heap_length := peak |>) = + SOME (t2 with <| stack := t1.stack; + locals := inter t1.locals (list_to_num_set (live ++ corr)); + locals_size := t1.locals_size; + stack_max := smx; + safe_for_space := safe; + peak_heap_length := peak|>)` + by (Q.PAT_X_ASSUM `xx = t2.stack` (ASSUME_TAC o GSYM) + \\ FULL_SIMP_TAC (srw_ss()) [call_env_def,push_env_def,flush_state_def, + pop_env_def,dataSemTheory.dec_clock_def,bviSemTheory.dec_clock_def, + FUNPOW_dec_clock_code,LET_DEF]) + \\ gvs [set_var_def, state_rel_def, lookup_insert, lookup_inter_alt, + lookup_map] + \\ rw [] + >- (last_x_assum drule \\ rw []) + >- gvs [domain_list_to_num_set, MEM_EL] + >- ( + gvs [domain_list_to_num_set] + \\ rpt (first_x_assum $ qspec_then `k` assume_tac \\ gvs [])) + >- gvs [domain_list_to_num_set] + >- gvs [domain_list_to_num_set] + >- gvs [call_env_def, push_env_def] + >- gvs [jump_exc_def, call_env_def, push_env_def, AllCaseEqs()]) (* Call *) \\ note_tac "Call" \\ Cases_on `handler` diff --git a/compiler/backend/proofs/data_liveProofScript.sml b/compiler/backend/proofs/data_liveProofScript.sml index f1dc949d3e..a14ebed270 100644 --- a/compiler/backend/proofs/data_liveProofScript.sml +++ b/compiler/backend/proofs/data_liveProofScript.sml @@ -334,13 +334,13 @@ Proof >- gvs [state_rel_def, flush_state_def] \\ ‘t1.code = s.code ∧ t1.stack_frame_sizes = s.stack_frame_sizes’ by gvs [state_rel_def] \\ gvs [] + \\ ‘t1.clock = s.clock’ by gvs [state_rel_def] \\ gvs [] + \\ Cases_on ‘s.clock = 0’ \\ gvs [] + >- gvs [state_rel_def, flush_state_def] \\ Cases_on ‘find_code (SOME loc) [x; v] s.code s.stack_frame_sizes’ \\ gvs [] \\ Cases_on ‘x'’ \\ gvs [] \\ Cases_on ‘r’ \\ gvs [] - \\ ‘t1.clock = s.clock’ by gvs [state_rel_def] \\ gvs [] - \\ Cases_on ‘s.clock = 0’ \\ gvs [] - >- gvs [state_rel_def, flush_state_def] \\ Cases_on ‘evaluate (q',call_env q r' (dec_clock s))’ \\ gvs [] \\ Cases_on ‘q''’ \\ gvs [] \\ fs [] @@ -408,16 +408,24 @@ Proof \\ ‘t1.refs = s.refs’ by gvs [state_rel_def] \\ gvs [] \\ Cases_on ‘dest_thunk x s.refs’ \\ gvs [] \\ Cases_on ‘t’ \\ gvs [] - >- (gvs [state_rel_def, set_var_def] \\ rw [lookup_insert]) - \\ ‘t1.code = s.code ∧ t1.stack_frame_sizes = s.stack_frame_sizes’ + >- ( + gvs [AllCaseEqs(), PULL_EXISTS, cut_env_def, state_rel_def, set_var_def] + \\ gvs [SF DNF_ss, lookup_insert, lookup_inter_alt] + \\ gvs [SUBSET_DEF, domain_lookup] \\ rw [] + \\ first_x_assum drule_all \\ rw []) + \\ ‘t1.code = s.code ∧ t1.stack_frame_sizes = s.stack_frame_sizes ∧ + t1.clock = s.clock’ by gvs [state_rel_def] \\ gvs [] + \\ Cases_on ‘s.clock = 0’ \\ gvs [] + >- gvs [state_rel_def, flush_state_def] \\ Cases_on ‘find_code (SOME loc) [x; v'] s.code s.stack_frame_sizes’ \\ gvs [] \\ Cases_on ‘x'’ \\ gvs [] \\ Cases_on ‘r’ \\ gvs [] \\ Cases_on ‘cut_env names s.locals’ \\ fs [] - \\ fs [cut_env_def] \\ reverse (srw_tac [] []) THEN1 - (pop_assum mp_tac \\ fs [] + \\ fs [cut_env_def] \\ reverse (srw_tac [] []) + >- ( + pop_assum mp_tac \\ fs [] \\ fs [SUBSET_DEF,domain_list_insert,domain_inter, domain_delete,state_rel_def] \\ rpt strip_tac \\ imp_res_tac get_vars_IMP_domain @@ -440,11 +448,6 @@ Proof (unabbrev_all_tac \\ fs [call_env_def, push_env_def, dec_clock_def] \\ fs [state_rel_def]) \\ qspecl_then [‘q'’,‘t4’] mp_tac evaluate_stack_swap - \\ Cases_on ‘s.clock = 0’ \\ fs [] - >- ( - gvs [state_rel_def, call_env_def] - \\ rpt (CASE_TAC \\ gvs []) - \\ fs [state_rel_def, call_env_def, state_component_equality]) \\ Cases_on ‘evaluate (q',t4)’ \\ fs [] \\ Cases_on ‘q''’ \\ fs [] \\ Cases_on ‘x'’ \\ fs [] >- ( diff --git a/compiler/backend/semantics/dataSemScript.sml b/compiler/backend/semantics/dataSemScript.sml index 78adfdf044..413edc2a09 100644 --- a/compiler/backend/semantics/dataSemScript.sml +++ b/compiler/backend/semantics/dataSemScript.sml @@ -1280,7 +1280,10 @@ Definition evaluate_def: | IsThunk Evaluated v => (case ret of | NONE => (SOME (Rval v),flush_state F s) - | SOME (dest,names) => (NONE, set_var dest v s)) + | SOME (dest,names) => + (case cut_env names s.locals of + | NONE => (SOME (Rerr(Rabort Rtype_error)),s) + | SOME env => (NONE, set_var dest v (s with locals := env)))) | IsThunk NotEvaluated f => (if s.clock = 0 then (SOME (Rerr(Rabort Rtimeout_error)), flush_state T s) From 9b300cf1d86210487a398cd63c76c2113fcd04e1 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Wed, 20 Aug 2025 16:43:59 +0300 Subject: [PATCH 062/112] Update `dataProps` --- .../backend/semantics/dataPropsScript.sml | 54 +++++++++---------- 1 file changed, 25 insertions(+), 29 deletions(-) diff --git a/compiler/backend/semantics/dataPropsScript.sml b/compiler/backend/semantics/dataPropsScript.sml index d8f183a4fa..53510b03a6 100644 --- a/compiler/backend/semantics/dataPropsScript.sml +++ b/compiler/backend/semantics/dataPropsScript.sml @@ -1063,8 +1063,6 @@ Proof \\ disch_then $ qspecl_then [‘smnew’,‘ssnew’,‘s.peak_heap_length’] mp_tac \\ rw [] \\ gvs [] \\ simp [state_component_equality]) - >- simp [push_env_def, call_env_def, dec_clock_def, - state_component_equality] >- ( rw [] >- gvs [call_env_def, push_env_def, dec_clock_def, pop_env_def, @@ -1668,18 +1666,20 @@ Proof \\ Cases_on ‘ret’ \\ gvs [] >- gvs [flush_state_def, state_component_equality, locals_ok_def] \\ Cases_on ‘x'’ \\ gvs [set_var_def] - \\ gvs [state_component_equality, locals_ok_def] \\ rw [lookup_insert]) + \\ Cases_on ‘cut_env r s.locals’ \\ gvs [] + \\ imp_res_tac locals_ok_cut_env \\ gvs [] + \\ gvs [state_component_equality, locals_ok_def]) \\ imp_res_tac locals_ok_get_var \\ gvs [] + \\ Cases_on ‘s.clock = 0’ \\ gvs [] + >- gvs [flush_state_def, state_component_equality, locals_ok_def] \\ Cases_on ‘find_code (SOME loc) [x; v] s.code s.stack_frame_sizes’ \\ gvs [] \\ Cases_on ‘x'’ \\ gvs [] \\ Cases_on ‘r’ \\ gvs [] \\ Cases_on ‘ret’ \\ gvs [] >- ( - Cases_on ‘s.clock = 0’ \\ gvs [] - >- gvs [flush_state_def, state_component_equality, locals_ok_def] - \\ `call_env q r' (dec_clock (s with locals := l)) = - call_env q r' (dec_clock s)` + ‘call_env q r' (dec_clock (s with locals := l)) = + call_env q r' (dec_clock s)’ by fs[state_component_equality, dec_clock_def, call_env_def, flush_state_def] \\ fs[] @@ -1691,11 +1691,10 @@ Proof \\ Cases_on ‘x'’ \\ gvs [] \\ Cases_on ‘cut_env r s.locals’ \\ gvs [] \\ imp_res_tac locals_ok_cut_env \\ gvs [] - \\ `call_env q r' (push_env x' F (dec_clock (s with locals := l))) = - call_env q r' (push_env x' F (dec_clock s))` - by fs[state_component_equality,dec_clock_def,call_env_def,push_env_def, flush_state_def] - \\ Cases_on ‘s.clock = 0’ \\ gvs [] - >- rw [state_component_equality, push_env_def, dec_clock_def, locals_ok_def] + \\ ‘call_env q r' (push_env x' F (dec_clock (s with locals := l))) = + call_env q r' (push_env x' F (dec_clock s))’ + by fs [state_component_equality, dec_clock_def, call_env_def, + push_env_def, flush_state_def] \\ qexistsl [‘s2.locals’,‘s2.safe_for_space’,‘s2.peak_heap_length’, ‘s2.stack_max’] \\ rw [state_component_equality, locals_ok_refl]) @@ -2320,7 +2319,11 @@ Proof >- ( Cases_on ‘ret’ \\ gvs [] >- gvs [flush_state_def, state_component_equality] - \\ Cases_on ‘x'’ \\ gvs [set_var_def, state_component_equality]) + \\ Cases_on ‘x'’ \\ gvs [] + \\ Cases_on ‘cut_env r' s.locals’ \\ gvs [] + \\ gvs [set_var_def, state_component_equality]) + \\ Cases_on ‘s.clock = 0’ \\ gvs [] + >- gvs [flush_state_def, state_component_equality] \\ Cases_on ‘find_code (SOME loc) [x; v] s.code s.stack_frame_sizes’ \\ gvs [] >- gvs [state_component_equality] @@ -2328,9 +2331,7 @@ Proof \\ Cases_on ‘r'’ \\ gvs [] \\ Cases_on ‘ret’ \\ gvs [] >- ( - Cases_on ‘s.clock = 0’ - >- gvs [flush_state_def, state_component_equality] - \\ gvs [dec_clock_def] + gvs [dec_clock_def] \\ Cases_on ‘evaluate (q',call_env q r'' (s with clock := s.clock − 1))’ \\ gvs [call_env_def] \\ Cases_on ‘q''’ \\ gvs [] @@ -2344,8 +2345,6 @@ Proof \\ Cases_on ‘x'’ \\ gvs [] \\ Cases_on ‘cut_env r' s.locals’ \\ gvs [] >- gvs [state_component_equality] - \\ Cases_on ‘s.clock = 0’ \\ gvs [] - >- gvs [push_env_def, call_env_def, dec_clock_def, state_component_equality] \\ gvs [push_env_def, call_env_def, dec_clock_def] \\ gvs [AllCaseEqs(), PULL_EXISTS] \\ qmatch_goalsub_abbrev_tac ‘stack_max_fupd (K smnew)’ @@ -2543,7 +2542,11 @@ Proof >- ( Cases_on ‘ret’ \\ gvs [] >- gvs [flush_state_def, state_component_equality] - \\ Cases_on ‘x'’ \\ gvs [set_var_def, state_component_equality]) + \\ Cases_on ‘x'’ \\ gvs [] + \\ Cases_on ‘cut_env r' s.locals’ \\ gvs [] + \\ gvs [set_var_def, state_component_equality]) + \\ Cases_on ‘s.clock = 0’ \\ gvs [] + >- gvs [flush_state_def, state_component_equality] \\ Cases_on ‘find_code (SOME loc) [x; v] s.code s.stack_frame_sizes’ \\ gvs [] >- ( @@ -2554,12 +2557,7 @@ Proof \\ Cases_on ‘r'’ \\ gvs [] \\ Cases_on ‘ret’ \\ gvs [] >- ( - Cases_on ‘s.clock = 0’ - >- ( - gvs [flush_state_def, state_component_equality] - \\ irule EVERY2_refl - \\ Cases \\ rw [stack_frame_size_rel_def]) - \\ gvs [dec_clock_def] + gvs [dec_clock_def] \\ Cases_on ‘evaluate (q',call_env q r'' (s with clock := s.clock − 1))’ \\ gvs [call_env_def] \\ Cases_on ‘q''’ \\ gvs [] @@ -2574,8 +2572,6 @@ Proof \\ Cases_on ‘x'’ \\ gvs [] \\ Cases_on ‘cut_env r' s.locals’ \\ gvs [] >- gvs [state_component_equality] - \\ Cases_on ‘s.clock = 0’ \\ gvs [] - >- gvs [push_env_def, call_env_def, dec_clock_def, state_component_equality] \\ gvs [push_env_def, call_env_def, dec_clock_def] \\ fs [AllCaseEqs(), PULL_EXISTS] \\ rveq \\ qmatch_goalsub_abbrev_tac ‘stack_max_fupd (K smnew)’ @@ -3067,16 +3063,16 @@ Proof >- ( gvs [AllCaseEqs(), PULL_EXISTS, flush_state_def] \\ gvs [cc_co_only_diff_def,state_component_equality,set_var_def]) + \\ TOP_CASE_TAC \\ gvs [] + >- gvs [cc_co_only_diff_def, flush_state_def] \\ gvs [CaseEq "prod"] \\ ntac 4 (TOP_CASE_TAC \\ gvs []) >- ( gvs [AllCaseEqs(), PULL_EXISTS, flush_state_def] - >- gvs [cc_co_only_diff_def] \\ first_x_assum (qspec_then ‘call_env q r' (dec_clock t)’ mp_tac) \\ gvs [cc_co_only_diff_def, call_env_def, dec_clock_def] \\ rw [] \\ gvs []) \\ ntac 3 (TOP_CASE_TAC \\ gvs []) - >- gvs [cc_co_only_diff_def, call_env_def, push_env_def, dec_clock_def] \\ gvs [CaseEq"prod"] \\ drule_then (qspecl_then [‘x'’,‘r'’,‘F’,‘q’] strip_assume_tac) cc_co_only_diff_call_env From 6511a909b7726fb962c74f12dc6ba3b5853cabb0 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Wed, 20 Aug 2025 17:10:51 +0300 Subject: [PATCH 063/112] Update `data_liveProof` and `data_spaceProof` --- compiler/backend/proofs/data_liveProofScript.sml | 2 +- compiler/backend/proofs/data_spaceProofScript.sml | 2 -- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/compiler/backend/proofs/data_liveProofScript.sml b/compiler/backend/proofs/data_liveProofScript.sml index a14ebed270..3759177c14 100644 --- a/compiler/backend/proofs/data_liveProofScript.sml +++ b/compiler/backend/proofs/data_liveProofScript.sml @@ -412,7 +412,7 @@ Proof gvs [AllCaseEqs(), PULL_EXISTS, cut_env_def, state_rel_def, set_var_def] \\ gvs [SF DNF_ss, lookup_insert, lookup_inter_alt] \\ gvs [SUBSET_DEF, domain_lookup] \\ rw [] - \\ first_x_assum drule_all \\ rw []) + \\ ntac 2 (first_x_assum drule_all \\ rw [])) \\ ‘t1.code = s.code ∧ t1.stack_frame_sizes = s.stack_frame_sizes ∧ t1.clock = s.clock’ by gvs [state_rel_def] \\ gvs [] diff --git a/compiler/backend/proofs/data_spaceProofScript.sml b/compiler/backend/proofs/data_spaceProofScript.sml index db0b155eec..a73f912f82 100644 --- a/compiler/backend/proofs/data_spaceProofScript.sml +++ b/compiler/backend/proofs/data_spaceProofScript.sml @@ -465,8 +465,6 @@ Proof by gvs [state_component_equality, dec_clock_def, call_env_def] \\ gvs [] \\ gvs [state_component_equality] \\ metis_tac [locals_ok_refl]) - >- gvs [call_env_def, dec_clock_def, push_env_def, - state_component_equality, locals_ok_def] >- ( gvs [PULL_EXISTS] \\ gvs [call_env_def, dec_clock_def, push_env_def, locals_ok_def] From 74253a099ad7910b2395d32c0113741ab7623fa9 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 21 Aug 2025 01:16:04 +0300 Subject: [PATCH 064/112] Get `data_to_wordProof` to build with cheats --- compiler/backend/proofs/data_to_wordProofScript.sml | 10 +++++++++- .../backend/proofs/data_to_word_memoryProofScript.sml | 4 ++-- 2 files changed, 11 insertions(+), 3 deletions(-) diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml index f3c3a4d7cb..0f8087ca48 100644 --- a/compiler/backend/proofs/data_to_wordProofScript.sml +++ b/compiler/backend/proofs/data_to_wordProofScript.sml @@ -1378,6 +1378,10 @@ Proof BasicProvers.EVERY_CASE_TAC>> fs[extract_labels_def,list_Seq_def,extract_labels_StoreEach, extract_labels_StoreAnyConsts,Maxout_bits_code_def]) + >~ [‘force_thunk’] >- ( + pairarg_tac \\ gvs [force_thunk_def, AllCaseEqs()] + >- gvs [GiveUp_def, extract_labels_def] + \\ cheat) >> (rpt (pairarg_tac>>fs[])>>rveq>> fs[extract_labels_def,EVERY_MEM,FORALL_PROD,ALL_DISTINCT_APPEND, @@ -1533,7 +1537,8 @@ Theorem comp_no_inst: addr_offset_ok ac 0w /\ byte_offset_ok ac 0w ⇒ every_inst (inst_ok_less ac) (FST(comp c n m p)) Proof - ho_match_mp_tac comp_ind>>Cases_on`p`>>rw[]>> + ho_match_mp_tac comp_ind>>Cases_on`p`>>rw[] + >~ [‘Force’] >- cheat >> simp[Once comp_def,every_inst_def]>> every_case_tac>>fs[]>> rpt(pairarg_tac>>fs[])>> @@ -1796,6 +1801,7 @@ Proof (fs[SUBSET_DEF]>>metis_tac[]) >- (fs[SUBSET_DEF]>>metis_tac[]) + >~ [‘force_thunk’] >- cheat >> EVAL_TAC>>rw[]>>fs[] QED @@ -1850,6 +1856,7 @@ Proof metis_tac[]) >- fs[word_good_handlers_assign] + >~ [‘force_thunk’] >- cheat >> EVAL_TAC>>rw[]>>fs[] QED @@ -2056,6 +2063,7 @@ Proof IF_CASES_TAC >> simp[comp_def,no_share_inst_def,list_Seq_no_share_inst] ) + >~ [‘Force’] >- cheat >> gvs[comp_def,no_share_inst_def] (* Raise | Return | Tick *) QED diff --git a/compiler/backend/proofs/data_to_word_memoryProofScript.sml b/compiler/backend/proofs/data_to_word_memoryProofScript.sml index 7dca0464f8..2ed1798de5 100644 --- a/compiler/backend/proofs/data_to_word_memoryProofScript.sml +++ b/compiler/backend/proofs/data_to_word_memoryProofScript.sml @@ -6391,7 +6391,7 @@ Proof \\ fs [encode_header_def,AC STAR_ASSOC STAR_COMM,thunk_tag_bits_lemma] QED -Theorem memory_rel_Thunk_IMP: +(*Theorem memory_rel_Thunk_IMP: memory_rel c be ts refs sp st m dm ((RefPtr bl nn,ptr)::vars) /\ lookup nn refs = SOME (Thunk ev v) /\ good_dimindex (:'a) ==> @@ -6405,7 +6405,7 @@ Theorem memory_rel_Thunk_IMP: ((v,m (x + bytes_in_word))::(RefPtr bl nn,ptr)::vars) Proof cheat -QED +QED*) Theorem word_list_exists_thm: (word_list_exists a 0 = emp) /\ From 09d7ec450da56fe888d6cc9801ff3b29f6677ab5 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Mon, 25 Aug 2025 17:08:20 +0300 Subject: [PATCH 065/112] Fixes after master merge --- compiler/backend/proofs/source_evalProofScript.sml | 13 +++++-------- semantics/proofs/evaluatePropsScript.sml | 3 ++- semantics/proofs/typeSoundScript.sml | 4 ++++ 3 files changed, 11 insertions(+), 9 deletions(-) diff --git a/compiler/backend/proofs/source_evalProofScript.sml b/compiler/backend/proofs/source_evalProofScript.sml index 1a7aa59a7d..d2aa0ad1d9 100644 --- a/compiler/backend/proofs/source_evalProofScript.sml +++ b/compiler/backend/proofs/source_evalProofScript.sml @@ -621,17 +621,16 @@ Proof \\ simp [Once do_app_cases] \\ rw [listTheory.SWAP_REVERSE_SYM] \\ fs [CaseEq "ffi_result", option_case_eq] \\ rveq \\ fs [] \\ simp [do_app_def] - >>~ [`thunk_op`] - >- gvs [thunk_op_def] + >~ [`thunk_op`] >- ( - gvs [AllCaseEqs(), thunk_op_def] + gvs [AllCaseEqs(), PULL_EXISTS, thunk_op_def] >- ( rpt (pairarg_tac \\ gvs []) \\ gvs [store_alloc_def, LIST_REL_EL_EQN]) + \\ Cases_on ‘xs’ \\ gvs [] \\ drule_then (drule_then (qsubterm_then `store_assign _ _` mp_tac)) - store_assign - \\ rw [EVERY2_LUPDATE_same] - \\ gvs [LIST_REL_EL_EQN]) + store_assign \\ rw [] + \\ gvs []) \\ simp [div_exn_v_def, sub_exn_v_def, chr_exn_v_def, EVERY2_refl, MEM_MAP, PULL_EXISTS] \\ TRY (drule_then imp_res_tac (CONJUNCT1 do_eq)) @@ -1809,8 +1808,6 @@ Proof >- (drule_then irule record_forward_trans \\ gvs []) >- (drule_then irule record_forward_trans \\ gvs []) >- (disj2_tac \\ drule_then irule record_forward_trans \\ gvs [])) - \\ rename1 ‘st2.fp_state.canOpt = FpScope fpValTree$Opt’ - \\ Cases_on ‘st2.fp_state.canOpt = FpScope fpValTree$Opt’ \\ gs[shift_fp_opts_def] \\ gs[] QED diff --git a/semantics/proofs/evaluatePropsScript.sml b/semantics/proofs/evaluatePropsScript.sml index 32abde73a5..d615de40eb 100644 --- a/semantics/proofs/evaluatePropsScript.sml +++ b/semantics/proofs/evaluatePropsScript.sml @@ -831,8 +831,9 @@ Theorem do_app_ffi_unchanged: !ffi2. do_app (refs, ffi2) op vs = SOME ((refs',ffi2), r) Proof disch_then (strip_assume_tac o REWRITE_RULE [do_app_cases]) - \\ rw [do_app_def] \\ gvs[AllCaseEqs()] + \\ rw [do_app_def] \\ gvs[thunk_op_def, AllCaseEqs()] >- metis_tac[] + >- (pairarg_tac \\ gvs []) \\ gvs [call_FFI_return_unchanged, Q.SPECL [`x`, `ExtCall ""`] ffiTheory.call_FFI_def] QED diff --git a/semantics/proofs/typeSoundScript.sml b/semantics/proofs/typeSoundScript.sml index 67fa0c54e6..9f72d3307c 100644 --- a/semantics/proofs/typeSoundScript.sml +++ b/semantics/proofs/typeSoundScript.sml @@ -1602,6 +1602,10 @@ Proof >> metis_tac [store_type_extension_trans]) >> `getOpClass op ≠ FunApp` by (Cases_on `op` >> fs[getOpClass_def,AllCaseEqs()]) + >> Cases_on ‘getOpClass op = Force’ + >- ( + Cases_on ‘op’ >> gvs[getOpClass_def,AllCaseEqs()] + >> Cases_on ‘ts’ >> fs[type_op_def]) >> Cases_on ‘getOpClass op = EvalOp’ >- ( Cases_on ‘op’ >> gs[getOpClass_def] From c3dfcf34cf27b5d2683981f705f0287e99effdfa Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Tue, 26 Aug 2025 19:18:49 +0300 Subject: [PATCH 066/112] Progress on getting thunks into the `cv_translator` --- compiler/backend/presLangScript.sml | 36 +++++++++++-------- .../serialiser/backend_enc_decScript.sml | 2 ++ cv_translator/backend_64_cvScript.sml | 7 ++++ cv_translator/to_data_cvScript.sml | 2 +- 4 files changed, 32 insertions(+), 15 deletions(-) diff --git a/compiler/backend/presLangScript.sml b/compiler/backend/presLangScript.sml index e62dd9a932..10e32031db 100644 --- a/compiler/backend/presLangScript.sml +++ b/compiler/backend/presLangScript.sml @@ -196,6 +196,14 @@ Definition thunk_mode_to_display_def: (thunk_mode_to_display NotEvaluated = empty_item (strlit "NotEvaluated")) End +Definition thunk_op_to_display_def: + (thunk_op_to_display (AllocThunk m) = + Item NONE (strlit "AllocThunk") [thunk_mode_to_display m]) ∧ + (thunk_op_to_display (UpdateThunk m) = + Item NONE (strlit "UpdateThunk") [thunk_mode_to_display m]) ∧ + (thunk_op_to_display ForceThunk = empty_item (strlit "ForceThunk")) +End + Definition op_to_display_def: op_to_display (p:ast$op) = case p of @@ -257,13 +265,7 @@ Definition op_to_display_def: | FFI v35 => empty_item (strlit "FFI v35") | Eval => empty_item (strlit "Eval") | Env_id => empty_item (strlit "Eval") - | ThunkOp t => - (case t of - | AllocThunk m => - Item NONE (strlit "AllocThunk") [thunk_mode_to_display m] - | UpdateThunk m => - Item NONE (strlit "UpdateThunk") [thunk_mode_to_display m] - | ForceThunk => empty_item (strlit "ForceThunk")) + | ThunkOp t => thunk_op_to_display t End Definition lop_to_display_def: @@ -486,13 +488,7 @@ Definition flat_op_to_display_def: | ConfigGC => empty_item (strlit "ConfigGC") | FFI s => Item NONE (strlit "FFI") [string_imp s] | Eval => empty_item (strlit "Eval") - | ThunkOp t => - (case t of - | AllocThunk m => - Item NONE (strlit "AllocThunk") [thunk_mode_to_display m] - | UpdateThunk m => - Item NONE (strlit "UpdateThunk") [thunk_mode_to_display m] - | ForceThunk => empty_item (strlit "ForceThunk")) + | ThunkOp t => thunk_op_to_display t | GlobalVarAlloc n => item_with_num (strlit "GlobalVarAlloc") n | GlobalVarInit n => item_with_num (strlit "GlobalVarInit") n | GlobalVarLookup n => item_with_num (strlit "GlobalVarLookup") n @@ -710,6 +706,7 @@ Definition clos_op_to_display_def: | WordOp (FP_bop op) => fp_bop_to_display op | WordOp (FP_top op) => fp_top_to_display op | Install => String (strlit "Install") + | ThunkOp t => thunk_op_to_display t End Triviality MEM_clos_exps_size: @@ -835,6 +832,9 @@ Definition bvl_to_display_def: Item NONE (strlit "call") (String (attach_name ns dest) :: (bvl_to_display_list ns h xs))) /\ + (bvl_to_display ns h (Force loc n) = + Item NONE (strlit "force") + [display_num_as_varn (h-n-1); String (attach_name ns (SOME loc))]) /\ (bvl_to_display ns h (Op op xs) = Item NONE (strlit "op") (clos_op_to_display ns op :: (bvl_to_display_list ns h xs))) ∧ @@ -893,6 +893,9 @@ Definition bvi_to_display_def: | SOME e => [Item NONE (strlit "handler") [display_num_as_varn h; empty_item (strlit "->"); bvi_to_display ns (h+1) e]]))) /\ + (bvi_to_display ns h (Force loc n) = + Item NONE (strlit "force") + [display_num_as_varn (h-n-1); String (attach_name ns (SOME loc))]) ∧ (bvi_to_display ns h (Op op xs) = Item NONE (strlit "op") (clos_op_to_display ns op :: (bvi_to_display_list ns h xs))) ∧ @@ -970,6 +973,11 @@ Definition data_prog_to_display_def: list_to_display num_to_display args; Item NONE (strlit "some") [Tuple [num_to_display v; data_prog_to_display k ns handler]]] + | Force ret loc src => Item NONE (strlit "force") + [option_to_display (\(x, y). Tuple + [num_to_display x; num_set_to_display y]) ret; + num_to_display loc; + num_to_display src] | Assign n op args n_set => Tuple [num_to_display n; String (strlit ":="); diff --git a/compiler/backend/serialiser/backend_enc_decScript.sml b/compiler/backend/serialiser/backend_enc_decScript.sml index 47490f022e..8f4e5b7175 100644 --- a/compiler/backend/serialiser/backend_enc_decScript.sml +++ b/compiler/backend/serialiser/backend_enc_decScript.sml @@ -201,6 +201,8 @@ val _ = reg_enc_dec closLang_const_enc'_thm; val res = define_enc_dec “:opw”; val res = define_enc_dec “:ast$shift”; +val res = define_enc_dec “:ast$thunk_mode” +val res = define_enc_dec “:ast$thunk_op”; val res = define_enc_dec “:fp_cmp”; val res = define_enc_dec “:fp_uop”; val res = define_enc_dec “:fp_bop”; diff --git a/cv_translator/backend_64_cvScript.sml b/cv_translator/backend_64_cvScript.sml index 4debddf481..08ac6b7efc 100644 --- a/cv_translator/backend_64_cvScript.sml +++ b/cv_translator/backend_64_cvScript.sml @@ -542,6 +542,13 @@ val _ = cv_trans (data_to_wordTheory.assign_def |> arch_spec |> SRULE data_to_wordTheory.arg3_def, data_to_wordTheory.arg4_def]) +val pre = cv_trans_pre "" (data_to_wordTheory.force_thunk_def |> arch_spec); +Theorem data_to_word_force_thunk_pre[cv_pre,local]: + ∀c secn l ret loc v1. data_to_word_force_thunk_pre c secn l ret loc v1 +Proof + cheat +QED + val pre = data_to_wordTheory.comp_def |> arch_spec |> SRULE [to_adjust_vars] |> cv_trans_pre ""; Theorem data_to_word_comp_pre[cv_pre,local]: ∀c secn l p. data_to_word_comp_pre c secn l p diff --git a/cv_translator/to_data_cvScript.sml b/cv_translator/to_data_cvScript.sml index c0f6f3c6e3..ef266339de 100644 --- a/cv_translator/to_data_cvScript.sml +++ b/cv_translator/to_data_cvScript.sml @@ -2193,7 +2193,7 @@ val _ = cv_auto_trans backend_asmTheory.to_bvl_def; (* Bring everything from bvl to the front -- everything because this file is too big for me to try everything separately. *) val bvl_names = - ["Var", "If", "Let", "Raise", "Handle", "Tick", "Call", "Op", "Bool", + ["Var", "If", "Let", "Raise", "Handle", "Tick", "Force", "Call", "Op", "Bool", "mk_tick"]; val _ = app (fn name => temp_bring_to_front_overload name {Name=name, Thy="bvl"}) bvl_names; From 68f58948dcb50de135a4ec97dbf723bc8a3a1eb0 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Tue, 26 Aug 2025 19:32:58 +0300 Subject: [PATCH 067/112] Small fix in `itree_semantics` --- semantics/alt_semantics/itree_semanticsScript.sml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/semantics/alt_semantics/itree_semanticsScript.sml b/semantics/alt_semantics/itree_semanticsScript.sml index e1fe85854a..1e98c75703 100644 --- a/semantics/alt_semantics/itree_semanticsScript.sml +++ b/semantics/alt_semantics/itree_semanticsScript.sml @@ -408,7 +408,7 @@ Definition application_def: (case do_opapp vs of SOME (env,e) => (Estep (env, s, Exp e, c):estep_result) | NONE => Etype_error) - | Force => + | Force => (case vs of [Loc _ n] => ( case store_lookup n s of @@ -416,8 +416,8 @@ Definition application_def: return env s v c | SOME (Thunk NotEvaluated f) => application Opapp env s [f; Conv NONE []] ((Cforce n,env)::c) - | _ => Etype_error - | _ => Etype_error + | _ => Etype_error) + | _ => Etype_error) | _ => case op of | FFI n => ( From ac85ea4b7d38f174ff355f1638aadf166603cd86 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Tue, 26 Aug 2025 19:41:22 +0300 Subject: [PATCH 068/112] Fix `itree_semanticsProps` --- semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml b/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml index b063b629da..1757686b2a 100644 --- a/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml +++ b/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml @@ -563,10 +563,10 @@ Proof gs[itree_semanticsTheory.do_app_def] >> every_case_tac >> gs[]) >> Cases_on ‘op’ >> gs[application_def] >> every_case_tac >> - gs[itree_semanticsTheory.do_app_def] >> + gs[itree_semanticsTheory.do_app_def, thunk_op_def] >> pop_assum $ mp_tac >> rpt (TOP_CASE_TAC >> gvs[SF itree_ss]) >> gs[store_alloc_def] >> - rpt (FULL_CASE_TAC >> gvs[thunk_op_def, store_alloc_def, store_assign_def]) + rpt (FULL_CASE_TAC >> gvs[store_alloc_def, store_assign_def]) QED Theorem application_FFI_results: From ab9498e53fad6b64dcb94bdc618ab7655756c37d Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Wed, 27 Aug 2025 10:26:26 +0300 Subject: [PATCH 069/112] Small fix after master merge --- compiler/backend/proofs/data_to_wordProofScript.sml | 1 + 1 file changed, 1 insertion(+) diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml index 8a6c242ce6..c02448199d 100644 --- a/compiler/backend/proofs/data_to_wordProofScript.sml +++ b/compiler/backend/proofs/data_to_wordProofScript.sml @@ -1518,6 +1518,7 @@ Proof IF_CASES_TAC >> simp[comp_def,no_share_inst_def,list_Seq_no_share_inst] ) + >~ [‘Force’] >- cheat >> gvs[comp_def,no_share_inst_def] (* Raise | Return | Tick *) QED From 28b8548f48d74a8238740f2c3896f9a1a6f18189 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Fri, 29 Aug 2025 13:48:15 +0200 Subject: [PATCH 070/112] Complete implementation of Force in data_to_word --- compiler/backend/data_to_wordScript.sml | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/compiler/backend/data_to_wordScript.sml b/compiler/backend/data_to_wordScript.sml index c2bd412a15..aa213aadd4 100644 --- a/compiler/backend/data_to_wordScript.sml +++ b/compiler/backend/data_to_wordScript.sml @@ -2445,14 +2445,13 @@ Definition force_thunk_def: (dtcase ret of | NONE => Return 0 [adjust_var v1] | SOME (dest,_) => Assign (adjust_var dest) (Var (adjust_var v1))) - (* rest is the implementation of AppUnit + update thunk *) - ARB (* (list_Seq [Assign 5 (Op And [Load (Op Add [Var 1; Const bytes_in_word])]); - Call (dtcase ret of - | NONE => NONE - | SOME (r,ns) => ([r],adjust_sets ns,Skip,secn,l)) - (SOME loc) [adjust_ar v1; 5] NONE])*)]),l+1) + Call + (dtcase ret of + | NONE => NONE + | SOME (r,ns) => SOME ([r],adjust_sets ns,Skip,secn,l)) + (SOME loc) [adjust_var v1; 5] NONE])]),l+1) : 'a wordLang$prog # num End @@ -2798,4 +2797,3 @@ Proof \\ pop_assum (fn th => once_rewrite_tac [th]) \\ rewrite_tac [th_FF,AnyArith_call_tree_def,structure_le_def]) QED - From 934fc273929308f27f567e60ab8a8f7faa9e7262 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Sat, 30 Aug 2025 15:39:44 +0300 Subject: [PATCH 071/112] Progress on `data_to_word_Proof` --- .../proofs/data_to_wordProofScript.sml | 120 ++++++++++++++++-- 1 file changed, 110 insertions(+), 10 deletions(-) diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml index c02448199d..e752605ddd 100644 --- a/compiler/backend/proofs/data_to_wordProofScript.sml +++ b/compiler/backend/proofs/data_to_wordProofScript.sml @@ -50,6 +50,38 @@ Proof \\ gvs[do_space_def,AllCaseEqs(),consume_space_def] QED +Theorem force_thunk_thm: + abs_ml_inv conf (RefPtr b ptr::stack) refs + (roots,heap,be,a,sp,sp1,gens) limit ts ∧ + (lookup ptr refs = SOME (Thunk NotEvaluated v)) ⇒ + ?p r roots2 v1 heap2 u. + (roots = r :: Pointer p u :: roots2) ∧ + (thunk_deref p heap = SOME v1) ∧ + (heap_store p [ThunkBlock ev r] heap = (heap2,T)) ∧ + abs_ml_inv conf (v::(RefPtr b ptr)::stack) + refs + (roots,heap2,be,a,sp,sp1,gens) limit ts +Proof + cheat +QED + +Theorem memory_rel_force_thunk: + memory_rel c be ts refs sp st m dm ((RefPtr bl nn,ptr)::vars) ∧ + lookup nn refs = SOME (Thunk ev v) ∧ + good_dimindex (:'a) ⇒ + ∃ptr_w x:'a word. + ptr = Word ptr_w ∧ + get_real_addr c st ptr_w = SOME x ∧ + x ∈ dm ∧ (x + bytes_in_word) ∈ dm ∧ + (ev = Evaluated ⇒ + ∃w w'. m x = Word w ∧ m (x + bytes_in_word) = Word w' ∧ + (w && 15w) = 14w) ∧ + memory_rel c be ts refs sp st m dm + ((v,m (x + bytes_in_word))::(RefPtr bl nn,ptr)::vars) +Proof + cheat +QED + Theorem data_compile_correct: !prog s c n l l1 l2 res s1 (t:('a,'c,'ffi)wordSem$state) locs. (dataSem$evaluate (prog,s) = (res,s1)) /\ @@ -125,7 +157,64 @@ Proof \\ Cases_on `names_opt` \\ fs [cut_state_opt_def] \\ srw_tac[][] \\ fs [] \\ fs [cut_state_def,cut_env_def] \\ every_case_tac \\ fs [] \\ rw [] \\ fs [set_var_def]) - >~ [‘evaluate (Force _ _ _,s)’] >- cheat + >~ [‘evaluate (Force _ _ _,s)’] >- ( + simp [comp_def] + \\ gvs [dataSemTheory.evaluate_def] + \\ Cases_on `get_var src s.locals` \\ gvs [] + \\ Cases_on `dest_thunk x s.refs` \\ gvs [] + \\ Cases_on `t'` \\ gvs [] + >- ( + imp_res_tac state_rel_get_var_IMP + \\ `∃v0 ptr. get_var src s.locals = SOME (RefPtr v0 ptr)` + by gvs [oneline dest_thunk_def, AllCaseEqs()] + \\ drule_all state_rel_get_var_RefPtr \\ rw [] \\ gvs [] + \\ gvs [state_rel_thm, oneline dest_thunk_def] + \\ Cases_on `lookup ptr s.refs` \\ gvs [] + \\ Cases_on `x` \\ gvs [] + \\ Cases_on `t'` \\ gvs [] + \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] + \\ drule_all memory_rel_get_var_IMP + \\ qpat_x_assum `memory_rel _ _ _ _ _ _ _ _ _` kall_tac \\ rw [] + \\ simp [force_thunk_def, wordSemTheory.evaluate_def] + \\ TOP_CASE_TAC \\ gvs [] + >- ( + fs[encode_header_def] + \\ fs[encode_header_def, state_rel_def, good_dimindex_def, limits_inv_def, + dimword_def, memory_rel_def, heap_in_memory_store_def, + consume_space_def, arch_size_def] + \\ rfs[NOT_LESS]) + \\ drule memory_rel_force_thunk \\ rw [] \\ gvs [] + \\ simp [wordSemTheory.evaluate_def, wordSemTheory.get_var_imm_def, + word_cmp_Test_1, word_bit_def, get_addr_0] + \\ simp [list_Seq_def, wordSemTheory.evaluate_def] + \\ `word_exp t (real_addr c (adjust_var src)) = SOME (Word x')` + by metis_tac [get_real_addr_lemma] \\ gvs [] + \\ gvs [wordSemTheory.set_var_def, wordSemTheory.word_exp_def, + wordSemTheory.get_var_def, wordSemTheory.mem_load_def, + wordSemTheory.the_words_def, word_op_def, + wordSemTheory.get_var_imm_def, asmTheory.word_cmp_def] + \\ Cases_on `ret` \\ gvs [] + >- ( + simp [wordSemTheory.evaluate_def, wordSemTheory.set_var_def, + wordSemTheory.word_exp_def, wordSemTheory.get_var_def, + lookup_insert, wordSemTheory.the_words_def, + word_op_def, wordSemTheory.mem_load_def] + \\ gvs [lookup_insert, wordSemTheory.get_vars_def, + wordSemTheory.get_var_def, flush_state_def, + wordSemTheory.flush_state_def] + \\ conj_tac + >- (imp_res_tac option_le_add_indv) + \\ simp [join_env_def] + \\ cheat) + \\ Cases_on `x''` \\ gvs [] + \\ Cases_on `cut_env r s.locals` \\ gvs [] + \\ simp [wordSemTheory.evaluate_def, wordSemTheory.word_exp_def, + wordSemTheory.get_var_def, lookup_insert, + wordSemTheory.the_words_def, word_op_def, + wordSemTheory.mem_load_def] + \\ gvs [wordSemTheory.set_var_def, set_var_def, lookup_insert] + \\ cheat) + \\ cheat) >~ [‘evaluate (Tick,s)’] >- (fs [comp_def,dataSemTheory.evaluate_def,wordSemTheory.evaluate_def] \\ `t.clock = s.clock` by fs [state_rel_def] \\ fs [] \\ srw_tac[][] @@ -1381,7 +1470,9 @@ Proof >~ [‘force_thunk’] >- ( pairarg_tac \\ gvs [force_thunk_def, AllCaseEqs()] >- gvs [GiveUp_def, extract_labels_def] - \\ cheat) + \\ gvs [extract_labels_def] + \\ CASE_TAC \\ gvs [list_Seq_def, extract_labels_def] + \\ CASE_TAC \\ gvs [extract_labels_def]) >> (rpt (pairarg_tac>>fs[])>>rveq>> fs[extract_labels_def,EVERY_MEM,FORALL_PROD,ALL_DISTINCT_APPEND, @@ -1518,7 +1609,12 @@ Proof IF_CASES_TAC >> simp[comp_def,no_share_inst_def,list_Seq_no_share_inst] ) - >~ [‘Force’] >- cheat + >~ [‘Force’] >- ( + gvs [comp_def, force_thunk_def, AllCaseEqs()] + >- gvs [GiveUp_def, no_share_inst_def] + \\ gvs [no_share_inst_def] + \\ CASE_TAC \\ gvs [no_share_inst_def, list_Seq_no_share_inst] + \\ CASE_TAC \\ gvs [no_share_inst_def]) >> gvs[comp_def,no_share_inst_def] (* Raise | Return | Tick *) QED @@ -1682,9 +1778,8 @@ Theorem comp_no_inst: addr_offset_ok ac 0w /\ byte_offset_ok ac 0w ⇒ every_inst (inst_ok_less ac) (FST(comp c n m p)) Proof - ho_match_mp_tac comp_ind>>Cases_on`p`>>rw[] - >~ [‘Force’] >- cheat >> - simp[Once comp_def,every_inst_def]>> + ho_match_mp_tac comp_ind>>Cases_on`p`>>rw[]>> + simp[Once comp_def,every_inst_def,force_thunk_def]>> every_case_tac>>fs[]>> rpt(pairarg_tac>>fs[])>> fs[assign_no_inst]>> @@ -1968,9 +2063,11 @@ Proof (fs[SUBSET_DEF]>>metis_tac[]) >- (fs[SUBSET_DEF]>>metis_tac[]) - >~ [‘force_thunk’] >- cheat - >> - EVAL_TAC>>rw[]>>fs[] + >~ [‘force_thunk’] >- ( + gvs [force_thunk_def] + \\ every_case_tac \\ gvs [GiveUp_def] + \\ cheat) >> + EVAL_TAC>>rw[]>>fs[] QED Triviality word_good_handlers_StoreEach: @@ -2023,7 +2120,10 @@ Proof metis_tac[]) >- fs[word_good_handlers_assign] - >~ [‘force_thunk’] >- cheat + >~ [‘force_thunk’] >- ( + gvs [force_thunk_def] + \\ every_case_tac \\ gvs [GiveUp_def] + \\ EVAL_TAC) >> EVAL_TAC>>rw[]>>fs[] QED From fc7cc19b4debda26caaa0e8217ad6187f52ef2cf Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Sat, 30 Aug 2025 18:32:33 +0300 Subject: [PATCH 072/112] Add `Force` to `get_code_labels` in `dataProps` and remove cheat in `data_to_wordProof` --- compiler/backend/proofs/data_to_wordProofScript.sml | 4 ++-- compiler/backend/semantics/dataPropsScript.sml | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml index e752605ddd..3be654e363 100644 --- a/compiler/backend/proofs/data_to_wordProofScript.sml +++ b/compiler/backend/proofs/data_to_wordProofScript.sml @@ -2065,8 +2065,8 @@ Proof (fs[SUBSET_DEF]>>metis_tac[]) >~ [‘force_thunk’] >- ( gvs [force_thunk_def] - \\ every_case_tac \\ gvs [GiveUp_def] - \\ cheat) >> + \\ every_case_tac \\ gvs [GiveUp_def, SUBSET_DEF] + \\ EVAL_TAC \\ rpt strip_tac \\ disj1_tac \\ gvs []) >> EVAL_TAC>>rw[]>>fs[] QED diff --git a/compiler/backend/semantics/dataPropsScript.sml b/compiler/backend/semantics/dataPropsScript.sml index 53510b03a6..15fa4cf16c 100644 --- a/compiler/backend/semantics/dataPropsScript.sml +++ b/compiler/backend/semantics/dataPropsScript.sml @@ -2164,6 +2164,7 @@ Definition get_code_labels_def: (get_code_labels (Call r d a h) = (case d of SOME x => {x} | _ => {}) ∪ (case h of SOME (n,p) => get_code_labels p | _ => {})) ∧ + (get_code_labels (Force _ loc _) = {loc}) ∧ (get_code_labels (Seq p1 p2) = get_code_labels p1 ∪ get_code_labels p2) ∧ (get_code_labels (If _ p1 p2) = get_code_labels p1 ∪ get_code_labels p2) ∧ (get_code_labels (Assign _ op _ _) = closLang$assign_get_code_label op) ∧ From 33b2911dc4dbe9ed3b048f87181a32e9939bae04 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Sun, 31 Aug 2025 01:31:20 +0300 Subject: [PATCH 073/112] Progress on `data_to_wordProof` --- .../proofs/data_to_wordProofScript.sml | 88 ++++++++++++------- 1 file changed, 56 insertions(+), 32 deletions(-) diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml index 3be654e363..f74260a588 100644 --- a/compiler/backend/proofs/data_to_wordProofScript.sml +++ b/compiler/backend/proofs/data_to_wordProofScript.sml @@ -50,36 +50,44 @@ Proof \\ gvs[do_space_def,AllCaseEqs(),consume_space_def] QED -Theorem force_thunk_thm: - abs_ml_inv conf (RefPtr b ptr::stack) refs - (roots,heap,be,a,sp,sp1,gens) limit ts ∧ - (lookup ptr refs = SOME (Thunk NotEvaluated v)) ⇒ - ?p r roots2 v1 heap2 u. - (roots = r :: Pointer p u :: roots2) ∧ - (thunk_deref p heap = SOME v1) ∧ - (heap_store p [ThunkBlock ev r] heap = (heap2,T)) ∧ - abs_ml_inv conf (v::(RefPtr b ptr)::stack) - refs - (roots,heap2,be,a,sp,sp1,gens) limit ts -Proof - cheat -QED - -Theorem memory_rel_force_thunk: - memory_rel c be ts refs sp st m dm ((RefPtr bl nn,ptr)::vars) ∧ - lookup nn refs = SOME (Thunk ev v) ∧ - good_dimindex (:'a) ⇒ - ∃ptr_w x:'a word. - ptr = Word ptr_w ∧ - get_real_addr c st ptr_w = SOME x ∧ - x ∈ dm ∧ (x + bytes_in_word) ∈ dm ∧ - (ev = Evaluated ⇒ - ∃w w'. m x = Word w ∧ m (x + bytes_in_word) = Word w' ∧ - (w && 15w) = 14w) ∧ - memory_rel c be ts refs sp st m dm - ((v,m (x + bytes_in_word))::(RefPtr bl nn,ptr)::vars) -Proof - cheat +Theorem memory_rel_Force_Evaluated: + memory_rel c be ts refs sp st m dm ((RefPtr bl nn,ptr)::vars) /\ + lookup nn refs = SOME (Thunk Evaluated v) /\ + good_dimindex (:'a) ==> + ?ptr_w x:'a word w w'. + ptr = Word ptr_w /\ + get_real_addr c st ptr_w = SOME x /\ + x IN dm /\ m x = Word w /\ + (x + bytes_in_word) IN dm /\ + (15w && w = 14w) (* cheated *) /\ + m (x + bytes_in_word) = Word w' (* cheated *) /\ + memory_rel c be ts refs sp st m dm + ((v,m (x + bytes_in_word))::(RefPtr bl nn,ptr)::vars) +Proof + rewrite_tac [CONJ_ASSOC] + \\ once_rewrite_tac [CONJ_COMM] + \\ fs [memory_rel_def,PULL_EXISTS] \\ rw [] + \\ asm_exists_tac \\ fs [] + \\ fs [word_ml_inv_def,PULL_EXISTS] \\ clean_tac + \\ rpt_drule (GEN_ALL deref_thm) \\ fs [domain_lookup] \\ strip_tac + \\ asm_exists_tac \\ fs [] + \\ Cases_on `v'` \\ fs [heap_el_def] + \\ every_case_tac \\ fs [] \\ clean_tac + \\ fs [GSYM CONJ_ASSOC,word_addr_def] + \\ fs [heap_in_memory_store_def] + \\ rpt_drule get_real_addr_get_addr \\ fs [] + \\ disch_then kall_tac + \\ drule LESS_LENGTH + \\ strip_tac \\ fs [] \\ clean_tac + \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND] + \\ fs [EL_LENGTH_APPEND] + \\ imp_res_tac heap_lookup_SPLIT + \\ PairCases_on `b` \\ fs [] + \\ fs [word_heap_APPEND,word_heap_def,word_el_def,word_payload_def] + \\ Cases_on `b0` \\ fs [word_payload_def] + \\ fs [word_list_def,word_list_APPEND,SEP_CLAUSES] \\ fs [SEP_F_def] + \\ SEP_R_TAC \\ fs [] + \\ cheat QED Theorem data_compile_correct: @@ -168,6 +176,7 @@ Proof \\ `∃v0 ptr. get_var src s.locals = SOME (RefPtr v0 ptr)` by gvs [oneline dest_thunk_def, AllCaseEqs()] \\ drule_all state_rel_get_var_RefPtr \\ rw [] \\ gvs [] + \\ imp_res_tac state_rel_cut_env \\ gvs [] \\ gvs [state_rel_thm, oneline dest_thunk_def] \\ Cases_on `lookup ptr s.refs` \\ gvs [] \\ Cases_on `x` \\ gvs [] @@ -183,7 +192,7 @@ Proof dimword_def, memory_rel_def, heap_in_memory_store_def, consume_space_def, arch_size_def] \\ rfs[NOT_LESS]) - \\ drule memory_rel_force_thunk \\ rw [] \\ gvs [] + \\ drule memory_rel_Force_Evaluated \\ rw [] \\ gvs [] \\ simp [wordSemTheory.evaluate_def, wordSemTheory.get_var_imm_def, word_cmp_Test_1, word_bit_def, get_addr_0] \\ simp [list_Seq_def, wordSemTheory.evaluate_def] @@ -205,7 +214,9 @@ Proof \\ conj_tac >- (imp_res_tac option_le_add_indv) \\ simp [join_env_def] - \\ cheat) + \\ first_x_assum (fn th => + mp_tac th THEN match_mp_tac memory_rel_rearrange) + \\ rw [] \\ gvs []) \\ Cases_on `x''` \\ gvs [] \\ Cases_on `cut_env r s.locals` \\ gvs [] \\ simp [wordSemTheory.evaluate_def, wordSemTheory.word_exp_def, @@ -213,6 +224,19 @@ Proof wordSemTheory.the_words_def, word_op_def, wordSemTheory.mem_load_def] \\ gvs [wordSemTheory.set_var_def, set_var_def, lookup_insert] + \\ rw [] + >- (first_x_assum $ drule_at (Pat `cut_env _ _ = _`) \\ rw []) + \\ gvs [inter_insert_ODD_adjust_set] + \\ pure_rewrite_tac [GSYM APPEND_ASSOC] + \\ irule memory_rel_insert \\ gvs [] + \\ first_x_assum (fn th => + mp_tac th THEN match_mp_tac memory_rel_rearrange) + \\ rw [] \\ gvs [] + \\ ntac 2 disj2_tac \\ ntac 2 disj1_tac \\ gvs [] + \\ gvs [join_env_def, MEM_MAP, MEM_FILTER] + \\ rpt (pairarg_tac \\ gvs []) + \\ qexists `(n,v)` \\ gvs [] + \\ gvs [MEM_toAList,lookup_inter_alt,lookup_insert,AllCaseEqs()] \\ cheat) \\ cheat) >~ [‘evaluate (Tick,s)’] >- From fce04d0c82e99b09c90abfa82720fd220cf29118 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Mon, 1 Sep 2025 00:43:42 +0300 Subject: [PATCH 074/112] Fixes for HOL changes --- compiler/backend/backendScript.sml | 10 +++++----- compiler/backend/data_to_wordScript.sml | 8 ++++---- .../backend/proofs/bvl_inlineProofScript.sml | 19 ++++++++++--------- .../backend/proofs/bvl_to_bviProofScript.sml | 2 +- .../proofs/data_to_wordProofScript.sml | 6 ++++-- 5 files changed, 24 insertions(+), 21 deletions(-) diff --git a/compiler/backend/backendScript.sml b/compiler/backend/backendScript.sml index 519160065a..d66ca40102 100644 --- a/compiler/backend/backendScript.sml +++ b/compiler/backend/backendScript.sml @@ -73,7 +73,7 @@ Definition compile_def: (c.lab_conf.asm_conf.addr_offset) p in let _ = empty_ffi (strlit "finished: stack_to_lab") in let res = attach_bitmaps names c bm - (lab_to_target$compile c.lab_conf (p:'a prog)) in + (lab_to_target$compile c.lab_conf (p:'a sec list)) in let _ = empty_ffi (strlit "finished: lab_to_target") in res End @@ -161,7 +161,7 @@ Definition to_lab_def: c.stack_conf c.data_conf (2 * max_heap_limit (:'a) c.data_conf - 1) (c.lab_conf.asm_conf.reg_count - (LENGTH c.lab_conf.asm_conf.avoid_regs +3)) (c.lab_conf.asm_conf.addr_offset) p in - (bm,c,p:'a prog,names) + (bm,c,p:'a sec list,names) End Definition to_target_def: @@ -215,7 +215,7 @@ Definition from_stack_def: c.stack_conf c.data_conf (2 * max_heap_limit (:'a) c.data_conf - 1) (c.lab_conf.asm_conf.reg_count - (LENGTH c.lab_conf.asm_conf.avoid_regs +3)) (c.lab_conf.asm_conf.addr_offset) p in - from_lab c names (p:'a prog) bm + from_lab c names (p:'a sec list) bm End Definition from_word_def: @@ -619,7 +619,7 @@ Definition compile_inc_progs_def: c.stack_conf.reg_names c.stack_conf.jump asm_c.addr_offset reg_count2 p in let ps = ps with <| lab_prog := keep_progs k p |> in - let target = lab_to_target$compile c.lab_conf (p:'a prog) in + let target = lab_to_target$compile c.lab_conf (p:'a sec list) in let ps = ps with <| target_prog := OPTION_MAP (\(bytes, _). (bytes, cur_bm)) target |> in let c = c with lab_conf updated_by (case target of NONE => I @@ -806,7 +806,7 @@ Theorem compile_inc_progs_for_eval_eq: c.stack_conf.reg_names c.stack_conf.jump asm_c'.addr_offset reg_count2 p in let _ = empty_ffi (strlit "finished: stack_to_lab") in - let target = lab_to_target$compile c.lab_conf (p:'a prog) in + let target = lab_to_target$compile c.lab_conf (p:'a sec list) in let _ = empty_ffi (strlit "finished: lab_to_target") in let c = c with lab_conf updated_by (case target of NONE => I | SOME (_, c') => K c') in diff --git a/compiler/backend/data_to_wordScript.sml b/compiler/backend/data_to_wordScript.sml index aa213aadd4..8f20b0bf90 100644 --- a/compiler/backend/data_to_wordScript.sml +++ b/compiler/backend/data_to_wordScript.sml @@ -1104,10 +1104,10 @@ Definition fp_top_inst_def: End Definition fp_bop_inst_def: - fp_bop_inst FP_Add = FPAdd 0 0 1 /\ - fp_bop_inst FP_Sub = FPSub 0 0 1 /\ - fp_bop_inst FP_Mul = FPMul 0 0 1 /\ - fp_bop_inst FP_Div = FPDiv 0 0 1 + fp_bop_inst (FP_Add :fp_bop) = FPAdd 0 0 1 /\ + fp_bop_inst FP_Sub = FPSub 0 0 1 /\ + fp_bop_inst FP_Mul = FPMul 0 0 1 /\ + fp_bop_inst FP_Div = FPDiv 0 0 1 End Definition fp_uop_inst_def: diff --git a/compiler/backend/proofs/bvl_inlineProofScript.sml b/compiler/backend/proofs/bvl_inlineProofScript.sml index 63ea2e339b..5cebd508ba 100644 --- a/compiler/backend/proofs/bvl_inlineProofScript.sml +++ b/compiler/backend/proofs/bvl_inlineProofScript.sml @@ -296,12 +296,13 @@ val evaluate_remove_ticks_thm = Definition remove_ticks_cc_def: remove_ticks_cc cc = - (λcfg prog'. cc cfg (MAP (I ## I ## (λx. HD (remove_ticks [x]))) prog')) + (λcfg prog'. + cc cfg (MAP (I ## I ## (λx. HD (bvl_inline$remove_ticks [x]))) prog')) End Definition remove_ticks_co_def: remove_ticks_co = - (I ## MAP (I ## I ## (λx. HD (remove_ticks [x])))) + (I ## MAP (I ## I ## (λx. HD (bvl_inline$remove_ticks [x])))) End Theorem evaluate_compile_prog: @@ -561,7 +562,7 @@ Proof QED val remove_ticks_CONS = prove( - ``!xs x. remove_ticks (x::xs) = + ``!xs x. bvl_inline$remove_ticks (x::xs) = HD (remove_ticks [x]) :: remove_ticks xs``, Cases \\ fs [remove_ticks_def]); @@ -1432,20 +1433,20 @@ val let_state_rel_def = let_state_rel_def |> SIMP_RULE (srw_ss()) [state_component_equality,GSYM CONJ_ASSOC]; Theorem HD_let_op[simp]: - [HD (let_op [x])] = let_op [x] + [HD (let_op [x :bvl$exp])] = let_op [x] Proof Cases_on `x` \\ simp_tac std_ss [let_op_def] \\ fs [] \\ CASE_TAC \\ fs [] QED val let_op_sing_thm = prove( - ``let_op_sing x = HD (let_op [x])``, + ``let_op_sing (x :bvl$exp) = HD (let_op [x])``, fs [let_op_sing_def] \\ once_rewrite_tac [GSYM HD_let_op] \\ fs []); val var_list_IMP_evaluate = prove( - ``!a2 a1 l xs s. - var_list (LENGTH a1) l xs /\ LENGTH (xs:bvl$exp list) = LENGTH a2 ==> + ``!a2 a1 l (xs :bvl$exp list) (s :('a, 'b) state). + var_list (LENGTH a1) l xs /\ LENGTH xs = LENGTH a2 ==> evaluate (l,a1++a2++env,s) = (Rval a2,s)``, Induct THEN1 (fs [APPEND_NIL,var_list_def] @@ -1464,14 +1465,14 @@ val var_list_IMP_evaluate = prove( val var_list_IMP_evaluate = prove( ``var_list 0 l xs /\ LENGTH (xs:bvl$exp list) = LENGTH a ==> - evaluate (l,a++env,s) = (Rval a,s)``, + evaluate (l,a++env,(s :('a, 'b) state)) = (Rval a,s)``, rw [] \\ match_mp_tac (Q.SPECL [`xs`,`[]`] var_list_IMP_evaluate |> SIMP_RULE std_ss [APPEND,LENGTH]) \\ asm_exists_tac \\ fs []); Theorem LENGTH_let_op: - !xs. LENGTH (let_op xs) = LENGTH xs + !(xs :bvl$exp list). LENGTH (let_op xs) = LENGTH xs Proof ho_match_mp_tac let_op_ind \\ rw [let_op_def] \\ CASE_TAC \\ fs [] diff --git a/compiler/backend/proofs/bvl_to_bviProofScript.sml b/compiler/backend/proofs/bvl_to_bviProofScript.sml index ca9bee1d8c..7c9cad1a47 100644 --- a/compiler/backend/proofs/bvl_to_bviProofScript.sml +++ b/compiler/backend/proofs/bvl_to_bviProofScript.sml @@ -2081,7 +2081,7 @@ Proof QED Theorem compile_inc_next: - compile_inc next1 prog1 = (next2,prog2) ==> + bvl_to_bvi$compile_inc next1 prog1 = (next2,prog2) ==> next1 <= next2 Proof rw [] \\ drule compile_inc_lemma \\ rw [] diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml index f74260a588..f3bf830713 100644 --- a/compiler/backend/proofs/data_to_wordProofScript.sml +++ b/compiler/backend/proofs/data_to_wordProofScript.sml @@ -984,7 +984,8 @@ Proof Cases_on`res1=SOME NotEnoughSpace`>>full_simp_tac(srw_ss())[]>-( first_x_assum(qspec_then`k+ck`mp_tac) >> simp[] >> CASE_TAC >> full_simp_tac(srw_ss())[] ) >> - qmatch_assum_abbrev_tac`n < LENGTH (SND (evaluate (exps,s))).ffi.io_events` >> + qmatch_asmsub_abbrev_tac + `n < LENGTH (SND (evaluate (exps,s))).ffi.io_events` >> Q.ISPECL_THEN[`exps`,`s`]mp_tac wordPropsTheory.evaluate_add_clock_io_events_mono >> disch_then(qspec_then`ck`mp_tac)>>simp[Abbr`s`]>>strip_tac>> qexists_tac`k`>>simp[]>> @@ -1212,7 +1213,8 @@ Proof Cases_on`res1=SOME NotEnoughSpace`>>full_simp_tac(srw_ss())[]>-( first_x_assum(qspec_then`k+ck`mp_tac) >> simp[] >> CASE_TAC >> full_simp_tac(srw_ss())[] ) >> - qmatch_assum_abbrev_tac`n < LENGTH (SND (evaluate (exps,s))).ffi.io_events` >> + qmatch_asmsub_abbrev_tac + `n < LENGTH (SND (evaluate (exps,s))).ffi.io_events` >> Q.ISPECL_THEN[`exps`,`s`]mp_tac wordPropsTheory.evaluate_add_clock_io_events_mono >> disch_then(qspec_then`ck`mp_tac)>>simp[Abbr`s`]>>strip_tac>> qexists_tac`k`>>simp[]>> From b702f194b46154bf380849e175258d6e3c0afccd Mon Sep 17 00:00:00 2001 From: Hrutvik Kanabar Date: Fri, 14 Feb 2025 15:27:01 +0000 Subject: [PATCH 075/112] Remove recursion in semantics when forcing thunks For functional big-step and itree semantics --- .../alt_semantics/itree_semanticsScript.sml | 6 ++--- .../proofs/itree_semanticsPropsScript.sml | 2 +- semantics/evaluateScript.sml | 26 ++++++++----------- semantics/proofs/evaluatePropsScript.sml | 22 ++++++++++++++++ 4 files changed, 36 insertions(+), 20 deletions(-) diff --git a/semantics/alt_semantics/itree_semanticsScript.sml b/semantics/alt_semantics/itree_semanticsScript.sml index 1e98c75703..c26a754dd9 100644 --- a/semantics/alt_semantics/itree_semanticsScript.sml +++ b/semantics/alt_semantics/itree_semanticsScript.sml @@ -415,7 +415,8 @@ Definition application_def: 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) | _ => @@ -436,9 +437,6 @@ Definition application_def: SOME (s', Rraise v) => Estep (env, s, Exn v,c) | SOME (s', Rval v) => return env s' v c | NONE => Etype_error ) -Termination - WF_REL_TAC ‘measure (λ(x,_). if x = ThunkOp ForceThunk then 1 else 0)’ >> - rw[] >> Cases_on ‘op’ >> gvs[] End Definition continue_def: diff --git a/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml b/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml index 1757686b2a..e7cea7581c 100644 --- a/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml +++ b/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml @@ -547,7 +547,7 @@ Theorem application_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) | _ => diff --git a/semantics/evaluateScript.sml b/semantics/evaluateScript.sml index 3bca05f49d..c97cf659f1 100644 --- a/semantics/evaluateScript.sml +++ b/semantics/evaluateScript.sml @@ -84,10 +84,6 @@ Definition sing_env_def: <| v := nsBind n v nsEmpty; c := nsEmpty |> : v sem_env End -Definition AppUnit_def: - AppUnit e = App Opapp [e; Con NONE []] -End - Definition evaluate_def[nocompute]: evaluate st env [] = ((st:'ffi state),Rval []) ∧ @@ -146,21 +142,21 @@ Definition evaluate_def[nocompute]: | NONE => (st', Rerr (Rabort Rtype_error)) ) | Force => - (case dest_thunk vs st'.refs of + (case dest_thunk (REVERSE vs) st'.refs of | BadRef => (st', Rerr (Rabort Rtype_error)) | NotThunk => (st', Rerr (Rabort Rtype_error)) | IsThunk Evaluated v => (st', Rval [v]) | IsThunk NotEvaluated f => - if st'.clock = 0 then - (st', Rerr (Rabort Rtimeout_error)) - else - case evaluate (dec_clock st') (sing_env "f" f) - [AppUnit (Var (Short "f"))] of - | (st2, Rval vs2) => - (case update_thunk vs st2.refs vs2 of - | NONE => (st2, Rerr (Rabort Rtype_error)) - | SOME refs => (st2 with refs := refs, Rval vs2)) - | (st2, Rerr e) => (st2, Rerr e)) + case do_opapp [f; Conv NONE []] of + | SOME (env',e) => + if st'.clock = 0 then (st', Rerr (Rabort Rtimeout_error)) else + (case evaluate (dec_clock st') env' [e] of + | (st2, Rval vs2) => + (case update_thunk (REVERSE vs) st2.refs vs2 of + | NONE => (st2, Rerr (Rabort Rtype_error)) + | SOME refs => (st2 with refs := refs, Rval vs2)) + | (st2, Rerr e) => (st2, Rerr e)) + | NONE => (st', Rerr (Rabort Rtype_error))) | EvalOp => (case fix_clock st' (do_eval_res (REVERSE vs) st') of (st1, Rval (env1, decs)) => diff --git a/semantics/proofs/evaluatePropsScript.sml b/semantics/proofs/evaluatePropsScript.sml index d615de40eb..50ef56067b 100644 --- a/semantics/proofs/evaluatePropsScript.sml +++ b/semantics/proofs/evaluatePropsScript.sml @@ -1405,3 +1405,25 @@ Proof \\ gvs [dec_clock_def,ADD1] QED +Theorem evaluate_Force_alt: + evaluate st env [App (ThunkOp ForceThunk) es] = + case evaluate st env (REVERSE es) of + | (st', Rval vs) => ( + case dest_thunk (REVERSE vs) st'.refs of + | BadRef => (st', Rerr (Rabort Rtype_error)) + | NotThunk => (st', Rerr (Rabort Rtype_error)) + | IsThunk Evaluated v => (st', Rval [v]) + | IsThunk NotEvaluated f => ( + case evaluate st' (sing_env "f" f) [App Opapp [Var (Short "f"); Con NONE []]] of + | (st2, Rval vs2) => ( + case update_thunk (REVERSE vs) st2.refs vs2 of + | NONE => (st2, Rerr (Rabort Rtype_error)) + | SOME refs => (st2 with refs := refs, Rval vs2)) + | res => res)) + | res => res +Proof + simp[Once evaluate_def] >> + ntac 4 (TOP_CASE_TAC >> simp[]) >> + simp[evaluate_def, sing_env_def, do_con_check_def, build_conv_def] >> + rpt (TOP_CASE_TAC >> simp[]) +QED From 5cccb671b99792b574d8047a37381382c0660e58 Mon Sep 17 00:00:00 2001 From: Hrutvik Kanabar Date: Sat, 30 Aug 2025 19:44:27 +0100 Subject: [PATCH 076/112] Move some thunk definitions From `evaluateTheory` to `semanticsPrimitivesTheory` --- semantics/evaluateScript.sml | 33 -------------------------- semantics/semanticPrimitivesScript.sml | 32 +++++++++++++++++++++++++ 2 files changed, 32 insertions(+), 33 deletions(-) diff --git a/semantics/evaluateScript.sml b/semantics/evaluateScript.sml index c97cf659f1..0c8eb5a00f 100644 --- a/semantics/evaluateScript.sml +++ b/semantics/evaluateScript.sml @@ -46,39 +46,6 @@ Proof Induct \\ fs [listTheory.list_size_def,listTheory.list_size_append] QED -(* With `dest_thunk` we check 3 things: - - The values contain exactly one reference - - The reference is valid - - The reference points to a thunk - We distinguish between `BadRef` and `NotThunk` instead of returning an option - with `NONE` for both, because we want `update_thunk` to succeed when - `dest_thunk` fails but only when the reference actually exists and points to - something other than a thunk. *) -Datatype: - dest_thunk_ret - = BadRef - | NotThunk - | IsThunk thunk_mode v -End - -Definition dest_thunk_def: - dest_thunk [Loc _ n] st = - (case store_lookup n st of - | NONE => BadRef - | SOME (Thunk Evaluated v) => IsThunk Evaluated v - | SOME (Thunk NotEvaluated v) => IsThunk NotEvaluated v - | SOME _ => NotThunk) ∧ - dest_thunk vs st = NotThunk -End - -Definition update_thunk_def: - update_thunk [Loc _ n] st [v] = - (case dest_thunk [v] st of - | NotThunk => store_assign n (Thunk Evaluated v) st - | _ => NONE) ∧ - update_thunk _ st _ = NONE -End - Definition sing_env_def: sing_env n v = <| v := nsBind n v nsEmpty; c := nsEmpty |> : v sem_env diff --git a/semantics/semanticPrimitivesScript.sml b/semantics/semanticPrimitivesScript.sml index 5e9fb399b0..87d0bae134 100644 --- a/semantics/semanticPrimitivesScript.sml +++ b/semantics/semanticPrimitivesScript.sml @@ -1185,3 +1185,35 @@ End val _ = set_fixity "+++" (Infixl 480); Overload "+++" = “extend_dec_env”; +(* With `dest_thunk` we check 3 things: + - The values contain exactly one reference + - The reference is valid + - The reference points to a thunk + We distinguish between `BadRef` and `NotThunk` instead of returning an option + with `NONE` for both, because we want `update_thunk` to succeed when + `dest_thunk` fails but only when the reference actually exists and points to + something other than a thunk. *) +Datatype: + dest_thunk_ret + = BadRef + | NotThunk + | IsThunk thunk_mode v +End + +Definition dest_thunk_def: + dest_thunk [Loc _ n] st = + (case store_lookup n st of + | NONE => BadRef + | SOME (Thunk Evaluated v) => IsThunk Evaluated v + | SOME (Thunk NotEvaluated v) => IsThunk NotEvaluated v + | SOME _ => NotThunk) ∧ + dest_thunk vs st = NotThunk +End + +Definition update_thunk_def: + update_thunk [Loc _ n] st [v] = + (case dest_thunk [v] st of + | NotThunk => store_assign n (Thunk Evaluated v) st + | _ => NONE) ∧ + update_thunk _ st _ = NONE +End From 388983acde450dbeb96d31c9cac4b31f6184d62d Mon Sep 17 00:00:00 2001 From: Hrutvik Kanabar Date: Sat, 30 Aug 2025 19:47:16 +0100 Subject: [PATCH 077/112] Update small step semantics --- .../proofs/smallStepPropsScript.sml | 20 ++++++++++++------- semantics/alt_semantics/smallStepScript.sml | 20 +++++++++++++++++++ 2 files changed, 33 insertions(+), 7 deletions(-) diff --git a/semantics/alt_semantics/proofs/smallStepPropsScript.sml b/semantics/alt_semantics/proofs/smallStepPropsScript.sml index 99dfec4e2f..c3c0960719 100644 --- a/semantics/alt_semantics/proofs/smallStepPropsScript.sml +++ b/semantics/alt_semantics/proofs/smallStepPropsScript.sml @@ -703,14 +703,17 @@ Theorem small_eval_app_err: e_step_reln^* (env0,s,Val v1,[Capp op v0 () es,env]) (env',s',e',c') ∧ e_step (env',s',e',c') = Eabort Rtype_error Proof - cheat (* ho_match_mp_tac small_eval_list_ind >> simp[] >> srw_tac[][] >> srw_tac[boolSimps.DNF_ss][Once RTC_CASES1,e_step_reln_def] >- ( - srw_tac[][Once e_step_def,continue_def,application_thm] >> + srw_tac[][Once e_step_def,continue_def,application_thm,return_def] >> BasicProvers.CASE_TAC >> TRY BasicProvers.CASE_TAC >> Cases_on`s` >> fs[do_app_cases] >> rw[] >> fs[] >> - rpt TOP_CASE_TAC >> gs[do_app_cases]) >> + rpt TOP_CASE_TAC >> gs[do_app_cases] >> + (* ThunkOp cases *) + namedCases_on ‘v0’ ["", "hd tl"] >> gvs[] >> Cases_on ‘tl’ >> gvs[] >> + gvs[oneline thunk_op_def, AllCaseEqs()] + ) >> disj2_tac >> srw_tac[][Once e_step_def,continue_def,push_def] >> imp_res_tac e_step_add_ctxt >> @@ -718,7 +721,7 @@ Proof full_simp_tac(srw_ss())[] >> first_x_assum(qspecl_then[`op`,`env'`,`v`,`v1::v0`]mp_tac) >> impl_tac >- simp[] >> - metis_tac[transitive_RTC,transitive_def] *) + metis_tac[transitive_RTC,transitive_def] QED Theorem small_eval_app_err_more: @@ -733,14 +736,17 @@ Theorem small_eval_app_err_more: e_step_reln^* (env0,s,Val v1,[Capp op v0 () es,env]) (env',s',e',c') ∧ e_step (env',s',e',c') = Eabort Rtype_error Proof - cheat (* ho_match_mp_tac small_eval_list_ind >> simp[] >> srw_tac[][] >> srw_tac[boolSimps.DNF_ss][Once RTC_CASES1,e_step_reln_def] >- ( srw_tac[][Once e_step_def,continue_def,application_thm] >> BasicProvers.CASE_TAC >> TRY BasicProvers.CASE_TAC >> Cases_on`s` >> fs[do_app_cases] >> rw[] >> fs[] >> - rpt TOP_CASE_TAC >> gs[do_app_cases]) >> + rpt TOP_CASE_TAC >> gs[do_app_cases] >> + (* ThunkOp cases *) + namedCases_on ‘v0’ ["", "hd tl"] >> gvs[] >> Cases_on ‘tl’ >> gvs[] >> + gvs[oneline thunk_op_def, AllCaseEqs()] + ) >> disj2_tac >> srw_tac[][Once e_step_def,continue_def,push_def] >> imp_res_tac e_step_add_ctxt >> @@ -748,7 +754,7 @@ Proof full_simp_tac(srw_ss())[] >> first_x_assum(qspecl_then[`op`,`env'`,`v`,`v1::v0`]mp_tac) >> impl_tac >- simp[] >> - metis_tac[transitive_RTC,transitive_def] *) + metis_tac[transitive_RTC,transitive_def] QED val _ = temp_delsimps ["getOpClass_def"] diff --git a/semantics/alt_semantics/smallStepScript.sml b/semantics/alt_semantics/smallStepScript.sml index 9c44435487..ab1ae92611 100644 --- a/semantics/alt_semantics/smallStepScript.sml +++ b/semantics/alt_semantics/smallStepScript.sml @@ -21,6 +21,7 @@ Datatype: Craise unit | Chandle unit ((pat # exp) list) | Capp op (v list) unit (exp list) + | Cforce num | Clog lop unit exp | Cif unit exp exp (* The value is raised if none of the patterns match *) @@ -83,6 +84,17 @@ Definition application_def: (case do_opapp vs of SOME (env,e) => Estep (env, s, Exp e, c) | NONE => Eabort Rtype_error) + | Force => ( + case vs of + | [Loc b n] => ( + case dest_thunk [Loc b n] (FST s) of + | BadRef => Eabort Rtype_error + | NotThunk => Eabort Rtype_error + | IsThunk Evaluated v => Estep (env, s, Val v, c) + | IsThunk NotEvaluated f => + Estep (env, s, Val f, + (Capp Opapp [Conv NONE []] () [], env)::(Cforce n, env)::c)) + | _ => Eabort Rtype_error) | _ => (case do_app s op vs of SOME (s',r) => @@ -108,6 +120,14 @@ Definition continue_def: application op env s (v::vs) c | (Capp op vs () (e::es), env) :: c => push env s e (Capp op (v::vs) () es) c + | (Cforce n, env) :: c => ( + case dest_thunk [v] (FST s) of + | BadRef => Eabort Rtype_error + | NotThunk => ( + case store_assign n (Thunk Evaluated v) (FST s) of + | SOME s' => return env (s', SND s) v c + | NONE => Eabort Rtype_error) + | IsThunk v3 v4 => Eabort Rtype_error) | (Clog l () e, env) :: c => (case do_log l v e of SOME (Exp e) => Estep (env, s, Exp e, c) From 0b9d45acf5e734c68c6d8439978c7c6b2bcd0e96 Mon Sep 17 00:00:00 2001 From: Hrutvik Kanabar Date: Sat, 30 Aug 2025 20:06:23 +0100 Subject: [PATCH 078/112] Update relational big-step semantics --- semantics/alt_semantics/bigStepScript.sml | 85 ++++++++++++++++++- .../proofs/bigStepPropsScript.sml | 8 ++ .../alt_semantics/proofs/determScript.sml | 1 - 3 files changed, 91 insertions(+), 3 deletions(-) diff --git a/semantics/alt_semantics/bigStepScript.sml b/semantics/alt_semantics/bigStepScript.sml index e5c1cd536d..c7280d46cc 100644 --- a/semantics/alt_semantics/bigStepScript.sml +++ b/semantics/alt_semantics/bigStepScript.sml @@ -40,7 +40,10 @@ Inductive opClass: (* FunApp *) (opClass Opapp FunApp) ∧ (* Eval *) -(opClass Eval EvalOp) +(opClass Eval EvalOp) ∧ +(* Thunks *) +(opClass (ThunkOp ForceThunk) Force) ∧ +(∀op. op ≠ ForceThunk ⇒ opClass (ThunkOp op) Simple) End (* ------------------------ Big step semantics -------------------------- *) @@ -153,10 +156,88 @@ evaluate ck env s1 (App op es) (s2, Rerr (Rabort Rtype_error))) ==> evaluate ck env s1 (App op es) (( s2 with<| refs := refs'; ffi :=ffi' |>), res)) +∧ + +(∀ck env op es vs s1 s2. + evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) ∧ + opClass op Force ∧ + dest_thunk (REVERSE vs) s2.refs = BadRef + ⇒ evaluate ck env s1 (App op es) (s2, Rerr (Rabort Rtype_error))) + +∧ + +(∀ck env op es vs s1 s2. + evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) ∧ + opClass op Force ∧ + dest_thunk (REVERSE vs) s2.refs = NotThunk + ⇒ evaluate ck env s1 (App op es) (s2, Rerr (Rabort Rtype_error))) + +∧ + +(∀ck env op es vs s1 s2 f. + evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) ∧ + opClass op Force ∧ + dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧ + do_opapp [f; Conv NONE []] = NONE + ⇒ evaluate ck env s1 (App op es) (s2, Rerr (Rabort Rtype_error))) + +∧ + +(∀ck env op es vs v s1 s2. + evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) ∧ + opClass op Force ∧ + dest_thunk (REVERSE vs) s2.refs = IsThunk Evaluated v + ⇒ evaluate ck env s1 (App op es) (s2, Rval v)) + +∧ + +(∀ck env op es vs s1 s2 f env_e. + evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) ∧ + opClass op Force ∧ + dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧ + do_opapp [f; Conv NONE []] = SOME env_e ∧ + ck ∧ s2.clock = 0 + ⇒ evaluate ck env s1 (App op es) (s2, Rerr (Rabort Rtimeout_error))) + +∧ + +(∀ck env op es vs s1 s2 f env' e s3 err. + evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) ∧ + opClass op Force ∧ + dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧ + do_opapp [f; Conv NONE []] = SOME (env', e) ∧ + (ck ⇒ s2.clock ≠ 0) ∧ + evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rerr err) + ⇒ evaluate ck env s1 (App op es) (s3, Rerr err)) + +∧ + +(∀ck env op es vs s1 s2 f env' e s3 vs2. + evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) ∧ + opClass op Force ∧ + dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧ + do_opapp [f; Conv NONE []] = SOME (env', e) ∧ + (ck ⇒ s2.clock ≠ 0) ∧ + evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rval vs2) ∧ + update_thunk (REVERSE vs) s3.refs [vs2] = NONE + ⇒ evaluate ck env s1 (App op es) (s3, Rerr (Rabort Rtype_error))) + +∧ + +(∀ck env op es vs s1 s2 f env' e s3 vs2 refs. + evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) ∧ + opClass op Force ∧ + dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧ + do_opapp [f; Conv NONE []] = SOME (env', e) ∧ + (ck ⇒ s2.clock ≠ 0) ∧ + evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rval vs2) ∧ + update_thunk (REVERSE vs) s3.refs [vs2] = SOME refs + ⇒ evaluate ck env s1 (App op es) (s3 with refs := refs, Rval vs2)) + /\ (! ck env op es vs s1 s2. evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) /\ do_app (s2.refs,s2.ffi) op (REVERSE vs) = NONE /\ - ¬opClass op FunApp + ¬opClass op FunApp ∧ ¬opClass op Force ==> evaluate ck env s1 (App op es) (s2, Rerr (Rabort Rtype_error))) diff --git a/semantics/alt_semantics/proofs/bigStepPropsScript.sml b/semantics/alt_semantics/proofs/bigStepPropsScript.sml index 0f96ad76ee..6e1ef2720b 100644 --- a/semantics/alt_semantics/proofs/bigStepPropsScript.sml +++ b/semantics/alt_semantics/proofs/bigStepPropsScript.sml @@ -31,6 +31,14 @@ Proof srw_tac[][] QED +Theorem opClass_11[simp]: + (opClass op Simple ⇒ ¬opClass op Force ∧ ¬opClass op FunApp) ∧ + (opClass op Force ⇒ ¬opClass op Simple ∧ ¬opClass op FunApp) ∧ + (opClass op FunApp ⇒ ¬opClass op Simple ∧ ¬opClass op Force) +Proof + Cases_on ‘op’ >> gvs[opClass_cases] +QED + Theorem evaluate_ignores_types_exns_eval: (∀ck env ^st e r. evaluate ck env st e r ⇒ diff --git a/semantics/alt_semantics/proofs/determScript.sml b/semantics/alt_semantics/proofs/determScript.sml index 7cb20b2eb3..06fe164aa0 100644 --- a/semantics/alt_semantics/proofs/determScript.sml +++ b/semantics/alt_semantics/proofs/determScript.sml @@ -38,7 +38,6 @@ Proof res_tac >> fs [] >> rw [] >> - ‘s with fp_state := s.fp_state = s’ by gs[state_component_equality] >> gs[] >> res_tac >> gs[] >> metis_tac [] QED From e8884d8cc7aa89df790ae9de95d2ce29e9741ff8 Mon Sep 17 00:00:00 2001 From: Hrutvik Kanabar Date: Sun, 31 Aug 2025 20:16:03 +0100 Subject: [PATCH 079/112] Update equivalence for functional/relational big-step semantics --- .../alt_semantics/proofs/bigClockScript.sml | 137 ++++++++++++++++-- .../proofs/funBigStepEquivScript.sml | 17 ++- .../alt_semantics/proofs/interpScript.sml | 47 ++++-- 3 files changed, 174 insertions(+), 27 deletions(-) diff --git a/semantics/alt_semantics/proofs/bigClockScript.sml b/semantics/alt_semantics/proofs/bigClockScript.sml index ff15f271fc..3528eec97d 100644 --- a/semantics/alt_semantics/proofs/bigClockScript.sml +++ b/semantics/alt_semantics/proofs/bigClockScript.sml @@ -77,7 +77,6 @@ Theorem big_unclocked_ignore: ⇒ evaluate_match F env (s with clock := count) v pes err_v (st' with clock := count, r)) Proof - cheat (* ho_match_mp_tac evaluate_ind >> rw [] >> rw [Once evaluate_cases]>> @@ -126,9 +125,42 @@ Proof qexists_tac ‘vs’ >> qexists_tac `s2 with clock := count'` >> rw[] >> - NO_TAC) >> + NO_TAC) + >>~ [‘dest_thunk’] + >- metis_tac[] + >- metis_tac[] + >- metis_tac[] + >- metis_tac[] + >- ( + ntac 3 disj2_tac >> disj1_tac >> + last_x_assum $ irule_at Any >> simp[] + ) + >- ( + ntac 3 disj2_tac >> disj1_tac >> + last_x_assum $ irule_at Any >> simp[] + ) + >- ( + ntac 4 disj2_tac >> disj1_tac >> + last_x_assum $ irule_at Any >> simp[] >> + first_x_assum $ irule_at Any >> simp[] + ) + >- ( + ntac 4 disj2_tac >> disj1_tac >> + last_x_assum $ irule_at Any >> simp[] >> + first_x_assum $ irule_at Any >> simp[] + ) + >- ( + disj2_tac >> + last_x_assum $ irule_at Any >> simp[] >> + last_x_assum $ irule_at Any >> simp[] + ) + >- ( + disj2_tac >> + last_x_assum $ irule_at Any >> simp[] >> + last_x_assum $ irule_at Any >> simp[] + ) >> rfs [] >> - metis_tac [with_clock_refs] *) + metis_tac [with_clock_refs] QED Theorem with_clock_with_clock[local]: @@ -185,7 +217,25 @@ Proof TRY (qexists_tac ‘s2 with clock := extra + s2.clock’ >> qexists_tac ‘v’ >> gs[state_component_equality] >> NO_TAC) >> TRY (qexists_tac ‘s2 with clock := extra + s2.clock’ >> - gs[state_component_equality] >> NO_TAC) >> + gs[state_component_equality] >> NO_TAC) + >>~ [‘ThunkOp ForceThunk’] + >- ( + ntac 3 disj2_tac >> disj1_tac >> + first_assum(match_exists_tac o (snd o strip_forall o concl)) >> + simp[] + ) + >- ( + ntac 4 disj2_tac >> disj1_tac >> + first_assum(match_exists_tac o (snd o strip_forall o concl)) >> + simp[] >> + first_assum(match_exists_tac o (snd o strip_forall o concl)) >> + simp[] + ) + >- ( + disj2_tac >> + last_x_assum $ qspec_then ‘extra’ $ irule_at Any >> simp[] >> + first_x_assum $ qspec_then ‘extra’ $ irule_at Any >> simp[] + ) >> disj1_tac >> CONV_TAC(STRIP_QUANT_CONV(move_conj_left(same_const``evaluate_list`` o fst o strip_comb))) >> first_assum(match_exists_tac o (snd o strip_forall o concl)) >> @@ -247,7 +297,27 @@ Proof TRY ( srw_tac[DNF_ss][] >> rewrite_tac[ CONJ_ASSOC] >> once_rewrite_tac [CONJ_COMM] >> - first_assum(match_exists_tac o concl) >> simp[] >> NO_TAC) >> + first_assum(match_exists_tac o concl) >> simp[] >> NO_TAC) + >>~ [‘ThunkOp ForceThunk’] + >- ( + gvs[] >> ntac 4 disj2_tac >> disj1_tac >> + dxrule $ cj 2 add_to_counter >> simp[] >> + disch_then $ qspec_then ‘c' + 1’ assume_tac >> + goal_assum drule >> simp[] + ) + >- ( + gvs[] >> ntac 4 disj2_tac >> disj1_tac >> + dxrule $ cj 2 add_to_counter >> simp[] >> + disch_then $ qspec_then ‘c' + 1’ assume_tac >> + rpt (goal_assum drule >> simp[]) + ) + >- ( + gvs[] >> disj2_tac >> + dxrule $ cj 2 add_to_counter >> simp[] >> + disch_then $ qspec_then ‘c' + 1’ assume_tac >> + goal_assum $ drule_at Any >> simp[] >> + goal_assum $ drule_at $ Pat ‘evaluate _ _ _ _ _’ >> simp[] + ) >> metis_tac [add_to_counter, with_clock_with_clock, with_clock_clock, arithmeticTheory.ADD_COMM, arithmeticTheory.ADD_0, with_clock_refs, result_distinct, error_result_distinct, result_11] @@ -468,7 +538,6 @@ Theorem big_clocked_total_lem[local]: !count_e env s. ∃s' r. evaluate T env (s with clock := FST count_e) (SND count_e) (s', r) Proof - cheat (* ho_match_mp_tac ind >> rw [] >> `?count e. count_e = (count,e)` by (PairCases_on `count_e` >> fs []) >> @@ -520,11 +589,30 @@ Proof `s2.clock-1 < s2.clock` by srw_tac [ARITH_ss] [] >> metis_tac [pair_CASES, clock_monotone, LESS_OR_EQ, LESS_TRANS, with_clock_clock]) >> + Cases_on ‘o' = ThunkOp ForceThunk’ >> gvs[] + >- ( (* Force *) + simp[opClass_cases] >> gvs[SF DNF_ss] >> + Cases_on ‘dest_thunk (REVERSE v) s2.refs’ >- metis_tac[] >- metis_tac[] >> + ntac 2 disj2_tac >> + Cases_on ‘t’ >> gvs[] >- metis_tac[] >> + rename1 ‘IsThunk _ f’ >> + Cases_on ‘do_opapp [f; Conv NONE []]’ >- metis_tac[] >> + rename1 ‘SOME env_e’ >> PairCases_on ‘env_e’ >> + ntac 2 disj2_tac >> + Cases_on ‘s2.clock = 0’ >- metis_tac[] >> + disj2_tac >> + last_x_assum $ qspec_then ‘s2.clock - 1’ mp_tac >> + last_x_assum kall_tac >> impl_tac + >- (imp_res_tac clock_monotone >> gvs[]) >> + disch_then $ qspecl_then [‘env_e1’,‘env_e0’,‘s2’] $ + qx_choosel_then [‘s3’,‘res’] assume_tac >> + reverse $ Cases_on ‘res’ >- metis_tac[] >> + disj2_tac >> Cases_on ‘update_thunk (REVERSE v) s3.refs [a]’ >> metis_tac[]) >> `(do_app (s2.refs,s2.ffi) o' (REVERSE v) = NONE) ∨ (?s3 e2. do_app (s2.refs,s2.ffi) o' (REVERSE v) = SOME (s3,e2))` by metis_tac [optionTheory.option_nchotomy, pair_CASES] >- (rename [‘op ≠ Opapp’] >> - ‘¬opClass op FunApp’ by simp[opClass_cases] >> simp[] >> + ‘¬opClass op FunApp ∧ ¬opClass op Force’ by simp[opClass_cases] >> simp[] >> metis_tac[]) >> cases_on ‘opClass o' Simple’ >> gs[] >- metis_tac [pair_CASES] >> ‘opClass o' EvalOp’ by (Cases_on ‘o'’ >> TRY (gs[opClass_cases] >> NO_TAC)) >> @@ -585,7 +673,7 @@ Proof >- ((* Letrec *) `exp_size e' < exp_size (Letrec l e')` by srw_tac [ARITH_ss] [exp_size_def] >> - metis_tac [result_nchotomy, optionTheory.option_nchotomy, error_result_nchotomy, with_clock_clock]) *) + metis_tac [result_nchotomy, optionTheory.option_nchotomy, error_result_nchotomy, with_clock_clock]) QED Theorem big_clocked_total: @@ -628,14 +716,14 @@ Theorem big_clocked_timeout_0: ⇒ (s'.clock = 0)) Proof - cheat (* ho_match_mp_tac evaluate_ind >> rw [] >> fs[do_app_cases, opClass_cases] >> rw [] >> fs [] >> every_case_tac >> fs[] >> rveq >> fs[] >> - gs[] >> every_case_tac >> gs[] *) + gs[] >> every_case_tac >> gs[] >> + gvs[thunk_op_def, AllCaseEqs(), store_alloc_def] QED Theorem big_clocked_unclocked_equiv_timeout: @@ -704,7 +792,34 @@ Proof >- metis_tac [pair_CASES, FST, clock_monotone, DECIDE “y + z ≤ x ⇒ (x = (x - z) + z:num)”] >~ [‘opClass op Simple (* a *)’] >- (‘¬opClass op FunApp’ by gs[opClass_cases] >> simp[] >> disj1_tac >> - first_assum $ irule_at (Pat ‘evaluate_list _ _ _ _ _ ’) >> simp[]) >> + first_assum $ irule_at (Pat ‘evaluate_list _ _ _ _ _ ’) >> simp[]) + >>~ [‘ThunkOp ForceThunk’] + >- simp[SF SFY_ss] + >- simp[SF SFY_ss] + >- simp[SF SFY_ss] + >- simp[SF SFY_ss] + >- simp[SF SFY_ss] + >- ( + ntac 8 disj2_tac >> disj1_tac >> + last_x_assum $ irule_at Any >> simp[] >> + first_x_assum $ irule_at Any >> simp[] >> + qexists ‘s2.clock - extra’ >> simp[] >> + imp_res_tac clock_monotone >> gvs[] + ) + >- ( + ntac 7 disj2_tac >> disj1_tac >> + last_x_assum $ irule_at Any >> simp[] >> + first_x_assum $ irule_at Any >> simp[] >> + qexists ‘s2.clock - extra’ >> simp[] >> + imp_res_tac clock_monotone >> gvs[] + ) + >- ( + rpt disj2_tac >> + last_x_assum $ irule_at Any >> simp[] >> + first_x_assum $ irule_at $ Pat ‘evaluate _ _ _ _ _’ >> simp[] >> + qexists ‘s2.clock - extra’ >> simp[] >> + imp_res_tac clock_monotone >> gvs[] + ) >> metis_tac [pair_CASES, FST, clock_monotone, DECIDE “y + z ≤ x ⇒ (x = (x - z) + z:num)”, with_clock_refs] QED diff --git a/semantics/alt_semantics/proofs/funBigStepEquivScript.sml b/semantics/alt_semantics/proofs/funBigStepEquivScript.sml index 0294e4222e..249e85d299 100644 --- a/semantics/alt_semantics/proofs/funBigStepEquivScript.sml +++ b/semantics/alt_semantics/proofs/funBigStepEquivScript.sml @@ -53,7 +53,6 @@ Theorem evaluate_eq_run_eval_list: evaluate_match s env v e errv = (I ## list_result) (run_eval_match env v e errv s)) Proof - cheat (* ho_match_mp_tac evaluate_ind >> rw[evaluate_def,run_eval_def, result_return_def,result_bind_def, Excl"getOpClass_def"] >> @@ -63,8 +62,17 @@ Proof ntac 3 TOP_CASE_TAC >> gs[Excl"getOpClass_def"] >- prove_tac >- prove_tac - >- prove_tac) >> - prove_tac *) + >- ( + qpat_x_assum ‘getOpClass _ = _’ kall_tac >> + simp[get_store_def] >> + TOP_CASE_TAC >> gvs[] >- prove_tac >- prove_tac >> + ntac 2 (TOP_CASE_TAC >> gvs[]) >- prove_tac >> + ntac 2 (TOP_CASE_TAC >> gvs[dec_clock_def]) >> + prove_tac + ) + >- prove_tac + ) >> + prove_tac QED Theorem functional_evaluate_list: @@ -87,7 +95,6 @@ Theorem evaluate_decs_eq_run_eval_decs: (s.eval_state = NONE ⇒ evaluate_decs s env decs = run_eval_decs env s decs) Proof - cheat (* recInduct evaluate_decs_ind >> rw[evaluate_decs_def,run_eval_dec_def,run_eval_dec_def] >> every_case_tac >> @@ -103,7 +110,7 @@ Proof rpt (qpat_x_assum ‘∀x. _’ kall_tac) >> gvs [evaluate_eq_run_eval_list] >> gvs [run_eval_def,result_return_def,result_bind_def] >> - gvs [EVERY_MEM,EXISTS_MEM] *) + gvs [EVERY_MEM,EXISTS_MEM] QED Theorem functional_evaluate_decs: diff --git a/semantics/alt_semantics/proofs/interpScript.sml b/semantics/alt_semantics/proofs/interpScript.sml index 8695667c05..7ac6317659 100644 --- a/semantics/alt_semantics/proofs/interpScript.sml +++ b/semantics/alt_semantics/proofs/interpScript.sml @@ -138,14 +138,12 @@ val _ = temp_delsimps["getOpClass_def"] Theorem getOpClass_opClass: (getOpClass op = FunApp ⇔ opClass op FunApp) ∧ - (getOpClass op = Simple ⇔ opClass op Simple) + (getOpClass op = Simple ⇔ opClass op Simple) ∧ + (getOpClass op = Force ⇔ opClass op Force) Proof - cheat (* - Cases_on ‘op’ >> gs[getOpClass_def, opClass_cases] *) + Cases_on ‘op’ >> gs[getOpClass_def, opClass_cases, AllCaseEqs()] QED - -(* Theorem run_eval_def: (!^st env l. run_eval env (Lit l) @@ -209,6 +207,25 @@ Theorem run_eval_def: do () <- dec_clock; run_eval env' e3 od) + | Force => + (case dest_thunk (REVERSE vs) st.refs of + | BadRef => raise (Rabort Rtype_error) + | NotThunk => raise (Rabort Rtype_error) + | IsThunk Evaluated v => return v + | IsThunk NotEvaluated f => + case do_opapp [f; Conv NONE []] of + | SOME (env',e) => do + () <- dec_clock; + v2 <- run_eval env' e; + ^st <- get_store; + (case update_thunk (REVERSE vs) st.refs [v2] of + | NONE => raise (Rabort Rtype_error) + | SOME refs => do + () <- set_store (st with refs := refs); + return v2; + od) + od + | NONE => raise (Rabort Rtype_error)) | Simple => (case do_app (st.refs,st.ffi) op (REVERSE vs) of | NONE => raise (Rabort Rtype_error) @@ -293,7 +310,6 @@ Theorem run_eval_def: raise (Rabort Rtype_error) od) Proof - cheat (* rw [GSYM evaluate_run_eval, FUN_EQ_THM, result_raise_def, result_return_def, result_bind_def, get_store_def, set_store_def] >> rw [Once evaluate_cases] @@ -322,8 +338,17 @@ Proof rw [] >> rw [] >> fs[state_transformerTheory.UNIT_DEF] >> metis_tac [PAIR_EQ, pair_CASES, SND, FST, run_eval_spec]) >> + Cases_on ‘getOpClass op = Force’ >> gvs[] + >- ( + gvs[getOpClass_opClass] >> + ‘¬opClass op FunApp ∧ ¬opClass op Simple’ by (Cases_on ‘op’ >> gvs[opClass_cases]) >> + simp[] >> + every_case_tac >> gvs[GSYM evaluate_run_eval_list, GSYM evaluate_run_eval] >> + metis_tac[] + ) >> Cases_on ‘getOpClass op = Simple’ >> gs[] - >- (‘~ opClass op FunApp’ by (Cases_on ‘op’ >> gs[getOpClass_def, opClass_cases]) >> + >- (‘~ opClass op FunApp ∧ ¬opClass op Force’ by + (Cases_on ‘op’ >> gs[getOpClass_def, opClass_cases,AllCaseEqs()]) >> gs[getOpClass_opClass] >> every_case_tac >> rw [] >> @@ -335,8 +360,9 @@ Proof rw [] >> fs[state_transformerTheory.UNIT_DEF] >> metis_tac [PAIR_EQ, pair_CASES, SND, FST, run_eval_spec]) >> ‘getOpClass op = EvalOp’ - by (Cases_on ‘op’ >> gs[opClass_cases, getOpClass_def]) >> gs[] >> - ‘~ opClass op FunApp’ by (Cases_on ‘op’ >> gs[getOpClass_def, opClass_cases]) >> + by (Cases_on ‘op’ >> gs[opClass_cases, getOpClass_def,AllCaseEqs()]) >> gs[] >> + ‘~ opClass op FunApp’ by + (Cases_on ‘op’ >> gs[getOpClass_def, opClass_cases,AllCaseEqs()]) >> gs[] >> every_case_tac >> gs[remove_lambda_pair] >> fs [GSYM evaluate_run_eval_list] >> Cases_on ‘op’ >> gs[opClass_cases, getOpClass_def] >> gs[do_app_def] @@ -381,9 +407,8 @@ Proof >- (every_case_tac >> rw [] >> fs [GSYM evaluate_run_eval_match, GSYM evaluate_run_eval] >> - rw [Once evaluate_cases]) *) + rw [Once evaluate_cases]) QED -*) Definition run_eval_dec_def: (run_eval_dec env ^st (Dlet _ p e) = From 3b5408b828510f55047db3ab425b638a65aeae8a Mon Sep 17 00:00:00 2001 From: Hrutvik Kanabar Date: Mon, 1 Sep 2025 19:36:52 +0100 Subject: [PATCH 080/112] Update equivalence for big-/small-step semantics --- .../proofs/bigSmallEquivScript.sml | 426 ++++++++++++++++-- .../proofs/bigSmallInvariantsScript.sml | 63 ++- 2 files changed, 450 insertions(+), 39 deletions(-) diff --git a/semantics/alt_semantics/proofs/bigSmallEquivScript.sml b/semantics/alt_semantics/proofs/bigSmallEquivScript.sml index 6889d671e3..eb9cd5ce0f 100644 --- a/semantics/alt_semantics/proofs/bigSmallEquivScript.sml +++ b/semantics/alt_semantics/proofs/bigSmallEquivScript.sml @@ -43,6 +43,12 @@ Proof rw[do_opapp_def] >> ntac 3 (TOP_CASE_TAC >> gvs[]) QED +Triviality opClass_op_Force[simp]: + opClass op Force ⇔ op = ThunkOp ForceThunk +Proof + Cases_on ‘op’ >> gvs[opClass_cases] +QED + val s = ``s:'ffi state``; val _ = temp_delsimps["getOpClass_def"] @@ -57,7 +63,6 @@ Theorem big_exp_to_small_exp: evaluate_match ck env s v pes err_v r ⇒ (ck = F) ⇒ small_eval_match env (to_small_st s) v pes err_v (to_small_res r)) Proof - cheat (* ho_match_mp_tac evaluate_ind >> srw_tac[][small_eval_log, small_eval_if, small_eval_match, small_eval_lannot, small_eval_handle, small_eval_let, small_eval_letrec, small_eval_tannot, to_small_res_def, small_eval_raise] @@ -259,7 +264,7 @@ Proof gvs[] >> Cases_on ‘es’ using SNOC_CASES >> gvs[] >- ( gvs[Once small_eval_list_cases, to_small_st_def, - do_app_def, AllCaseEqs(), store_alloc_def] >> + do_app_def, AllCaseEqs(), store_alloc_def,thunk_op_def] >> simp[small_eval_def] >> irule_at Any RTC_SUBSET >> simp[e_step_reln_def, e_step_def, application_thm, do_app_def, store_alloc_def, return_def] @@ -322,6 +327,242 @@ Proof simp[e_step_def, continue_def, application_thm, to_small_st_def] ) ) + >- ( + gvs[] >> Cases_on ‘es’ using SNOC_CASES >> + gvs[Once small_eval_list_cases, oneline dest_thunk_def, AllCaseEqs()] >> + gvs[Once small_eval_list_cases, small_eval_def] >> + irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, push_def] >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> + simp[e_step_def, continue_def, application_def, getOpClass_def, to_small_st_def, + dest_thunk_def] + ) + >- ( + gvs[] >> Cases_on ‘es’ using SNOC_CASES + >- ( + gvs[Once small_eval_list_cases, dest_thunk_def, to_small_st_def] >> + simp[small_eval_def] >> irule_at Any RTC_REFL >> + simp[e_step_def, application_def, getOpClass_def] + ) >> + Cases_on ‘l’ >> gvs[REVERSE_SNOC] + >- ( + ntac 2 $ gvs[Once small_eval_list_cases] >> + simp[small_eval_def] >> + irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, push_def] >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> + simp[e_step_def, continue_def, application_def, getOpClass_def] >> + gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_st_def] + ) >> + last_x_assum mp_tac >> once_rewrite_tac[GSYM APPEND] >> + rewrite_tac[small_eval_list_Rval_APPEND] >> strip_tac >> gvs[] >> + rev_dxrule e_step_to_App_mid >> + disch_then $ qspecl_then [‘h’,‘[]’,‘ThunkOp ForceThunk’,‘[]’] assume_tac >> gvs[] >> + simp[small_eval_def] >> irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, REVERSE_SNOC, push_def] >> + irule_at Any RTC_RTC >> first_x_assum $ irule_at Any >> + ntac 2 $ gvs[Once small_eval_list_cases] >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> + simp[e_step_def, continue_def, application_def, getOpClass_def] >> + gvs[REVERSE_APPEND, oneline dest_thunk_def, AllCaseEqs(), to_small_st_def] + ) + >- ( + gvs[] >> Cases_on ‘es’ using SNOC_CASES + >- ( + gvs[Once small_eval_list_cases, dest_thunk_def, to_small_st_def] >> + simp[small_eval_def] >> irule_at Any RTC_REFL >> + simp[e_step_def, application_def, getOpClass_def] + ) >> + Cases_on ‘l’ >> gvs[REVERSE_SNOC] + >- ( + ntac 2 $ gvs[Once small_eval_list_cases] >> + simp[small_eval_def] >> + irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, push_def] >> + irule_at Any $ cj 2 RTC_RULES_RIGHT1 >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> + simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >> + gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_st_def] >> + simp[e_step_def, continue_def, application_def, getOpClass_def] + ) >> + last_x_assum mp_tac >> once_rewrite_tac[GSYM APPEND] >> + rewrite_tac[small_eval_list_Rval_APPEND] >> strip_tac >> gvs[] >> + rev_dxrule e_step_to_App_mid >> + disch_then $ qspecl_then [‘h’,‘[]’,‘ThunkOp ForceThunk’,‘[]’] assume_tac >> gvs[] >> + simp[small_eval_def] >> irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, REVERSE_SNOC, push_def] >> + irule_at Any RTC_RTC >> first_x_assum $ irule_at Any >> + ntac 2 $ gvs[Once small_eval_list_cases] >> + irule_at Any $ cj 2 RTC_RULES_RIGHT1 >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> + simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >> + gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_st_def] >> + simp[e_step_def, continue_def, application_def, getOpClass_def] + ) + >- ( + gvs[] >> Cases_on ‘es’ using SNOC_CASES + >- ( + gvs[Once small_eval_list_cases, dest_thunk_def, to_small_st_def] >> + simp[small_eval_def] >> irule_at Any RTC_REFL >> + simp[e_step_def, application_def, getOpClass_def] + ) >> + Cases_on ‘l’ >> gvs[REVERSE_SNOC] + >- ( + ntac 2 $ gvs[Once small_eval_list_cases] >> + simp[small_eval_def] >> + irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, push_def] >> + irule_at Any $ cj 2 RTC_RULES_RIGHT1 >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> + simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >> + gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_st_def] + ) >> + last_x_assum mp_tac >> once_rewrite_tac[GSYM APPEND] >> + rewrite_tac[small_eval_list_Rval_APPEND] >> strip_tac >> gvs[] >> + rev_dxrule e_step_to_App_mid >> + disch_then $ qspecl_then [‘h’,‘[]’,‘ThunkOp ForceThunk’,‘[]’] assume_tac >> gvs[] >> + simp[small_eval_def] >> irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, REVERSE_SNOC, push_def] >> + irule_at Any RTC_RTC >> first_x_assum $ irule_at Any >> + ntac 2 $ gvs[Once small_eval_list_cases] >> + irule_at Any $ cj 2 RTC_RULES_RIGHT1 >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> + simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >> + gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_st_def] + ) + >- ( + gvs[] >> Cases_on ‘es’ using SNOC_CASES + >- ( + gvs[Once small_eval_list_cases, dest_thunk_def, to_small_st_def] >> + simp[small_eval_def] >> irule_at Any RTC_REFL >> + simp[e_step_def, application_def, getOpClass_def] + ) >> + Cases_on ‘l’ >> gvs[REVERSE_SNOC] + >- ( + irule_at Any small_eval_prefix >> + dxrule_at Any small_eval_err_add_ctxt >> simp[] >> + disch_then $ irule_at Any >> + ntac 2 $ gvs[Once small_eval_list_cases] >> + irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, push_def] >> + irule_at Any RTC_RTC >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> + irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >> + gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_st_def] >> + irule_at Any RTC_SUBSET >> + simp[e_step_reln_def, e_step_def, continue_def, application_def, getOpClass_def] + ) >> + last_x_assum mp_tac >> once_rewrite_tac[GSYM APPEND] >> + rewrite_tac[small_eval_list_Rval_APPEND] >> strip_tac >> gvs[] >> + rev_dxrule e_step_to_App_mid >> + disch_then $ qspecl_then [‘h’,‘[]’,‘ThunkOp ForceThunk’,‘[]’] assume_tac >> gvs[] >> + irule_at Any small_eval_prefix >> + dxrule_at Any small_eval_err_add_ctxt >> simp[] >> + disch_then $ irule_at Any >> + ntac 2 $ gvs[Once small_eval_list_cases] >> + irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, e_step_def, push_def] >> TOP_CASE_TAC >> gvs[] >> + irule_at Any RTC_RTC >> pop_assum $ irule_at Any >> + irule_at Any RTC_RTC >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> + irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >> + gvs[REVERSE_APPEND, oneline dest_thunk_def, AllCaseEqs(), to_small_st_def] >> + irule_at Any RTC_SUBSET >> + simp[e_step_reln_def, e_step_def, continue_def, application_def, getOpClass_def] + ) + >- ( + gvs[] >> Cases_on ‘es’ using SNOC_CASES + >- ( + gvs[Once small_eval_list_cases, dest_thunk_def, to_small_st_def] >> + simp[small_eval_def] >> irule_at Any RTC_REFL >> + simp[e_step_def, application_def, getOpClass_def] + ) >> + Cases_on ‘l’ >> gvs[REVERSE_SNOC] + >- ( + ntac 2 $ gvs[Once small_eval_list_cases] >> + simp[small_eval_def] >> + irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, push_def] >> + irule_at Any RTC_RTC >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> + irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >> + gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_st_def] >> + irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >> + gvs[small_eval_def] >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> + simp[e_step_def, continue_def] >> gvs[update_thunk_def, AllCaseEqs()] + ) >> + last_x_assum mp_tac >> once_rewrite_tac[GSYM APPEND] >> + rewrite_tac[small_eval_list_Rval_APPEND] >> strip_tac >> gvs[] >> + rev_dxrule e_step_to_App_mid >> + disch_then $ qspecl_then [‘h’,‘[]’,‘ThunkOp ForceThunk’,‘[]’] assume_tac >> gvs[] >> + simp[small_eval_def] >> irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, REVERSE_SNOC, push_def] >> + irule_at Any RTC_RTC >> first_x_assum $ irule_at Any >> + ntac 2 $ gvs[Once small_eval_list_cases] >> + irule_at Any RTC_RTC >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> + irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >> + gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_st_def] >> + irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >> + gvs[small_eval_def] >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> + simp[e_step_reln_def, Once e_step_def, continue_def] >> + gvs[update_thunk_def, AllCaseEqs()] + ) + >- ( + gvs[] >> Cases_on ‘es’ using SNOC_CASES + >- ( + gvs[Once small_eval_list_cases, dest_thunk_def, to_small_st_def] >> + simp[small_eval_def] >> irule_at Any RTC_REFL >> + simp[e_step_def, application_def, getOpClass_def] + ) >> + Cases_on ‘l’ >> gvs[REVERSE_SNOC] + >- ( + ntac 2 $ gvs[Once small_eval_list_cases] >> + simp[small_eval_def] >> + irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, push_def] >> + irule_at Any RTC_RTC >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> + irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >> + gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_st_def] >> + irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >> + gvs[small_eval_def] >> + irule_at Any $ cj 2 RTC_RULES_RIGHT1 >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> + simp[e_step_reln_def, e_step_def, continue_def, return_def] >> + gvs[update_thunk_def, AllCaseEqs()] + ) >> + last_x_assum mp_tac >> once_rewrite_tac[GSYM APPEND] >> + rewrite_tac[small_eval_list_Rval_APPEND] >> strip_tac >> gvs[] >> + rev_dxrule e_step_to_App_mid >> + disch_then $ qspecl_then [‘h’,‘[]’,‘ThunkOp ForceThunk’,‘[]’] assume_tac >> gvs[] >> + simp[small_eval_def] >> irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, REVERSE_SNOC, push_def] >> + irule_at Any RTC_RTC >> first_x_assum $ irule_at Any >> + ntac 2 $ gvs[Once small_eval_list_cases] >> + irule_at Any RTC_RTC >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> + irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >> + gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_st_def] >> + irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >> + gvs[small_eval_def] >> + irule_at Any $ cj 2 RTC_RULES_RIGHT1 >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> + simp[e_step_reln_def, Once e_step_def, continue_def, return_def] >> + gvs[update_thunk_def, AllCaseEqs()] + ) >- ( gvs[small_eval_def] >> Cases_on ‘es’ using SNOC_CASES >> gvs[] >- ( @@ -555,7 +796,7 @@ Proof >- metis_tac [small_eval_match_rules, FST, pair_CASES, to_small_st_def] >- metis_tac [small_eval_match_rules, FST, pair_CASES, to_small_st_def] >- metis_tac [small_eval_match_rules, FST, pair_CASES, to_small_st_def] - >- metis_tac [small_eval_match_rules] *) + >- metis_tac [small_eval_match_rules] QED Theorem evaluate_ctxts_cons: @@ -622,13 +863,38 @@ Proof simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss, opClass_cases]) >- (disj2_tac >> disj1_tac >> simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss, opClass_cases]) - >- (‘~ opClass op FunApp’ + >- (‘~ opClass op FunApp ∧ ¬ opClass op Force’ by (Cases_on ‘op’ >> gs[opClass_cases]) >> gs[] >> disj1_tac >> irule_at Any EQ_REFL >> - simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss]) - >- (gs[] >> disj2_tac >> disj1_tac >> - simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss]) + rpt (goal_assum drule)) + >- simp[SF SFY_ss] + >- ( + disj2_tac >> disj1_tac >> simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss] + ) + >- ( + ntac 2 disj2_tac >> disj1_tac >> + simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss] + ) + >- simp[SF SFY_ss] + >- simp[SF SFY_ss] + >- ( + ntac 4 disj2_tac >> disj1_tac >> + simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss] + ) + >- ( + ntac 4 disj2_tac >> disj1_tac >> + simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss] + ) + >- ( + disj2_tac >> + simp[Once evaluate_cases, PULL_EXISTS] >> + irule_at Any EQ_REFL >> simp[SF SFY_ss] + ) + >- ( + disj2_tac >> disj1_tac >> + simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss] + ) >- (rpt disj2_tac >> simp[Once evaluate_cases, SF SFY_ss]) QED @@ -639,7 +905,6 @@ Theorem one_step_backward: evaluate_state ck (env',s with <| refs := refs'; ffi := ffi' ; |>,e',c') bv ⇒ evaluate_state ck (env,s with <| refs := refs; ffi := ffi ; |>,e,c) bv Proof - cheat (* rw[e_step_def] >> Cases_on `e` >> gvs[] >- ( Cases_on `e''` >> gvs[push_def, return_def] @@ -664,6 +929,7 @@ Proof gvs[AllCaseEqs(), store_alloc_def, return_def] >> simp[Once evaluate_state_cases] >> gvs[Once evaluate_state_cases, getOpClass_def] >> goal_assum $ dxrule_at Any >> ntac 2 $ simp[Once evaluate_cases, opClass_cases] >> + gvs[AllCaseEqs(), thunk_op_def] >> simp[do_app_def, store_alloc_def] >> irule_at Any EQ_REFL ) >> gvs[SWAP_REVERSE_SYM] >> metis_tac[evaluate_state_app_cons] @@ -680,28 +946,51 @@ Proof rename1 ‘getOpClass op’ >> Cases_on ‘getOpClass op’ >> gs[] >> once_rewrite_tac[cj 2 evaluate_cases] >> simp[] >> every_case_tac >> gvs[SF DNF_ss, SF SFY_ss] - >- (‘opClass op FunApp’ by (Cases_on ‘op’ >> gs[getOpClass_def, opClass_cases]) >> - ‘~ opClass op Simple’ by (Cases_on ‘op’ >> gs[opClass_cases]) >> - gs[] >> - disj1_tac >> qexists_tac `clk + 1` >> simp[SF SFY_ss]) - >- (‘opClass op FunApp’ by (Cases_on ‘op’ >> gs[getOpClass_def, opClass_cases]) >> - ‘~ opClass op Simple’ by (Cases_on ‘op’ >> gs[opClass_cases]) >> - gs[] >> first_x_assum $ irule_at Any >> gs[]) + >- ( + gvs[getOpClass_opClass] >> + ‘op ≠ ThunkOp ForceThunk’ by gvs[opClass_cases] >> simp[] >> + disj1_tac >> qexists_tac `clk + 1` >> simp[SF SFY_ss] + ) + >- ( + gvs[getOpClass_opClass] >> + ‘op ≠ ThunkOp ForceThunk’ by gvs[opClass_cases] >> simp[] >> + first_x_assum $ irule_at Any >> gvs[] + ) ) >- ( - rename1 ‘getOpClass op’ >> Cases_on ‘getOpClass op’ >> gs[] >> + rename1 ‘getOpClass op’ >> Cases_on ‘getOpClass op’ >> gs[] + >~ [‘getOpClass op = Force’] + >- ( + ‘¬opClass op FunApp ∧ ¬opClass op Simple ∧ op = ThunkOp ForceThunk’ + by gvs[getOpClass_opClass, opClass_cases] >> + simp[SF DNF_ss, GSYM DISJ_ASSOC] >> gvs[AllCaseEqs()] + >- ( + ntac 3 disj2_tac >> disj1_tac >> simp[Once evaluate_cases, SF SFY_ss] + ) >> + once_rewrite_tac[cj 2 evaluate_cases] >> simp[] >> + gvs[evaluate_ctxts_cons] >> + gvs[evaluate_ctxt_cases, update_thunk_def, AllCaseEqs(), SF SFY_ss] >> + gvs[Once $ cj 2 evaluate_cases] >> + gvs[opClass_cases] >> metis_tac[] + ) >> once_rewrite_tac[cj 2 evaluate_cases] >> simp[] >> every_case_tac >> gvs[SF DNF_ss, SF SFY_ss] >> Cases_on ‘op’ >> - gs[do_app_def, getOpClass_def, opClass_cases] >> + gs[do_app_def, getOpClass_def, opClass_cases, AllCaseEqs()] >> gvs[evaluate_ctxts_cons] >> gvs[evaluate_ctxt_cases, SF SFY_ss] ) >- ( - rename1 ‘getOpClass op’ >> Cases_on ‘getOpClass op’ >> gs[] >> + rename1 ‘getOpClass op’ >> Cases_on ‘getOpClass op’ >> gs[] + >~ [‘getOpClass op = Force’] + >- ( + ‘¬opClass op FunApp ∧ ¬opClass op Simple ∧ op = ThunkOp ForceThunk’ + by gvs[getOpClass_opClass, opClass_cases] >> + simp[SF DNF_ss, GSYM DISJ_ASSOC] >> gvs[AllCaseEqs()] + ) >> once_rewrite_tac[cj 2 evaluate_cases] >> simp[] >> every_case_tac >> gvs[SF DNF_ss, SF SFY_ss] >> Cases_on ‘op’ >> - gs[do_app_def, getOpClass_def, opClass_cases] >> + gs[do_app_def, getOpClass_def, opClass_cases, AllCaseEqs()] >> gvs[evaluate_ctxts_cons] >> gvs[evaluate_ctxt_cases, SF SFY_ss] ) >~ [`evaluate_match`] @@ -717,7 +1006,7 @@ Proof gvs[AllCaseEqs()] >> gvs[evaluate_state_cases, evaluate_ctxts_cons, evaluate_ctxt_cases, evaluate_ctxts_cons, evaluate_ctxt_cases, ADD1, SF SFY_ss, getOpClass_opClass] - ) *) + ) QED Theorem evaluate_ctxts_type_error: @@ -750,7 +1039,6 @@ Theorem one_step_backward_type_error: ⇒ evaluate_state ck (env,s,e,c) (s, Rerr (Rabort a)) Proof - cheat (* srw_tac[][e_step_def] >> cases_on `e` >> full_simp_tac(srw_ss())[] @@ -768,13 +1056,20 @@ Proof gs[getOpClass_opClass] >- (Cases_on ‘op’ >> gs[getOpClass_def, to_small_st_def, do_app_def] >> simp[opClass_cases] >> simp[evaluate_list_NIL] >> - qexists_tac ‘s.clock’ >> gs[state_component_equality]) - >- (gs[AllCaseEqs()] >> + qexists_tac ‘s.clock’ >> gs[state_component_equality] >> + gvs[AllCaseEqs()]) + >- ( + gs[AllCaseEqs()] >> ‘~ opClass op Simple’ by (Cases_on ‘op’ >> gs[opClass_cases, getOpClass_def]) >> simp[evaluate_list_NIL] >> - qexists_tac ‘s.clock’ >> gs[state_component_equality]) - >- (‘~ opClass op FunApp’ + qexists ‘s.clock’ >> gvs[state_component_equality] + ) + >- ( + simp[evaluate_list_NIL, dest_thunk_def] >> + simp[state_component_equality] + ) + >- (‘~ opClass op FunApp ∧ ¬ opClass op Force’ by (Cases_on ‘op’ >> gs[opClass_cases]) >> gs[AllCaseEqs(), evaluate_list_NIL, to_small_st_def, return_def] >- (qexists_tac ‘s.clock’ >> gs[state_component_equality]) >> @@ -788,23 +1083,30 @@ Proof every_case_tac >> full_simp_tac(srw_ss())[evaluate_state_cases, push_def, return_def] >> srw_tac[][evaluate_ctxts_cons, evaluate_ctxt_cases, to_small_st_def] >> - srw_tac[][PULL_EXISTS] (* 15 *) + srw_tac[][PULL_EXISTS] (* 20 *) >- ( full_simp_tac(srw_ss())[application_thm] >> rename1 ‘getOpClass op’ >> Cases_on ‘getOpClass op’ >> - gs[getOpClass_opClass] (* 3 *) + gs[getOpClass_opClass] (* 5 *) >- (Cases_on ‘op’ >> gs[getOpClass_def, to_small_st_def, do_app_def] >> rveq >> gs[opClass_cases] >> qexists_tac ‘s.clock’ >> simp[Once evaluate_cases] >> irule_at Any evaluate_ctxts_type_error_matchable >> - gs[state_component_equality]) + gs[state_component_equality] >> + gvs[AllCaseEqs()]) >- (‘~ opClass op Simple’ by (Cases_on ‘op’ >> gs[opClass_cases]) >> every_case_tac >> gs[] >> qexists_tac ‘s.clock’ >> simp[evaluate_list_NIL] >> - irule evaluate_ctxts_type_error_matchable >> + irule_at Any evaluate_ctxts_type_error_matchable >> gs[state_component_equality]) - >- (‘~ opClass op FunApp’ + >- ( + simp[evaluate_list_NIL] >> + irule_at Any evaluate_ctxts_type_error_matchable >> + gvs[AllCaseEqs(), dest_thunk_def] >> + gvs[state_component_equality, to_small_st_def] + ) + >- (‘~ opClass op FunApp ∧ ¬opClass op Force’ by (Cases_on ‘op’ >> gs[opClass_cases]) >> gs[] >> qexists_tac ‘s.clock’ >> simp[evaluate_list_NIL] >> @@ -819,7 +1121,7 @@ Proof srw_tac[DNF_ss][] >> full_simp_tac(srw_ss())[to_small_st_def] >> ((irule_at Any evaluate_ctxts_type_error_matchable >> srw_tac[][state_component_equality] >> rpt $ irule_at Any EQ_REFL) ORELSE - metis_tac[do_con_check_build_conv,NOT_SOME_NONE]) *) + metis_tac[do_con_check_build_conv,NOT_SOME_NONE]) QED Theorem small_exp_to_big_exp: @@ -1413,7 +1715,6 @@ Theorem big_exp_to_small_exp_timeout_lemma: ∀s'. r = (s', Rerr (Rabort Rtimeout_error)) ∧ ck ⇒ e_step_to_match env (to_small_st s) v pes (to_small_st s')) Proof - cheat (* ho_match_mp_tac evaluate_strongind >> rw[] >- ( (* Raise *) irule_at Any $ cj 2 RTC_rules >> @@ -1460,7 +1761,7 @@ Proof gvs[Once small_eval_list_cases, to_small_res_def] >> last_x_assum $ assume_tac o GSYM >> simp[SF SFY_ss] ) >> - Cases_on ‘op’ >> gs[getOpClass_def] >> + Cases_on ‘op’ >> gs[getOpClass_def, AllCaseEqs()] >> gvs[to_small_res_def] >> dxrule e_step_over_App_Opapp >> disch_then $ qspecl_then [`env'`,`e`,`[]`] assume_tac >> gvs[] >> simp[Once RTC_CASES_RTC_TWICE, SF SFY_ss] @@ -1475,13 +1776,43 @@ Proof gvs[Once small_eval_list_cases, to_small_res_def] >> last_x_assum $ assume_tac o GSYM >> simp[] >> irule_at Any $ cj 1 RTC_rules ) >> - Cases_on ‘op’ >> gs[getOpClass_def] >> + Cases_on ‘op’ >> gs[getOpClass_def, AllCaseEqs()] >> gvs[to_small_res_def] >> dxrule e_step_over_App_Opapp >> disch_then $ qspecl_then [`env'`,`e`,`[]`] assume_tac >> gvs[SF SFY_ss] ) >- ( (* App - do_app timeout *) drule do_app_not_timeout >> simp[] ) + >- ( (* Force - timeout *) + dxrule big_clocked_to_unclocked_list >> rw[] >> + dxrule $ cj 2 big_exp_to_small_exp >> rw[] >> + gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_res_def] >> + imp_res_tac small_eval_list_length >> gvs[LENGTH_EQ_NUM_compute] >> + ntac 2 $ gvs[Once small_eval_list_cases] >> + irule_at Any $ cj 2 RTC_rules >> + simp[e_step_reln_def, e_step_def, push_def, application_thm] >> + irule_at Any $ cj 2 RTC_RULES_RIGHT1 >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> + simp[e_step_reln_def, e_step_def, continue_def, application_thm, getOpClass_def] >> + gvs[dest_thunk_def, to_small_st_def] + ) + >- ( (* Force *) + dxrule big_clocked_to_unclocked_list >> rw[] >> + dxrule $ cj 2 big_exp_to_small_exp >> rw[] >> + gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_res_def] >> + imp_res_tac small_eval_list_length >> gvs[LENGTH_EQ_NUM_compute] >> + ntac 2 $ gvs[Once small_eval_list_cases] >> + irule_at Any $ cj 2 RTC_rules >> + simp[e_step_reln_def, e_step_def, push_def, application_thm] >> + irule_at Any RTC_RTC >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> + irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, e_step_def, continue_def, application_thm, getOpClass_def] >> + gvs[dest_thunk_def, to_small_st_def] >> + irule_at Any $ cj 2 RTC_RULES >> + simp[e_step_reln_def, e_step_def, continue_def, application_thm, getOpClass_def] >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any + ) >- ( (* App - before application *) irule_at Any $ cj 2 RTC_rules >> simp[e_step_reln_def, e_step_def, push_def, application_thm] >> @@ -1589,7 +1920,7 @@ Proof >- ( (* match *) simp[Once e_step_to_match_cases] >> disj2_tac >> simp[Once to_small_st_def, SF SFY_ss] - ) *) + ) QED Theorem big_exp_to_small_exp_timeout: @@ -1898,7 +2229,6 @@ QED Theorem evaluate_ctxt_T_total: ∀env s c v. ∃r. evaluate_ctxt T env s c v r Proof - cheat (* rw[] >> simp[Once evaluate_ctxt_cases] >> Cases_on ‘c’ >> gvs[SF DNF_ss] >- ( qspecl_then [‘l0’,‘env’,‘s’] assume_tac big_clocked_list_total >> gvs[] >> @@ -1912,11 +2242,31 @@ Proof ) >> Cases_on ‘opClass op Simple’ >> gvs[] >- ( + ‘op ≠ ThunkOp ForceThunk’ by (Cases_on ‘op’ >> gvs[opClass_cases]) >> simp[] >> Cases_on ‘do_app (r0.refs,r0.ffi) op (REVERSE a ++ [v] ++ l)’ >> gvs[SF SFY_ss] >> - PairCases_on ‘x’ >> gvs[SF SFY_ss]) >> + PairCases_on ‘x’ >> gvs[SF SFY_ss] + ) >> + Cases_on ‘opClass op Force’ >> gvs[] + >- ( + rename1 ‘evaluate_list _ _ _ _ (s2,Rval vs2)’ >> + Cases_on ‘dest_thunk (REVERSE vs2 ++ [v] ++ l) s2.refs’ >> gvs[SF SFY_ss] >> + rename1 ‘IsThunk t f’ >> Cases_on ‘t’ >> gvs[SF SFY_ss] >> + Cases_on ‘do_opapp [f; Conv NONE []]’ >> gvs[SF SFY_ss] >> + rename1 ‘SOME env_e’ >> PairCases_on ‘env_e’ >> + Cases_on ‘s2.clock = 0’ >> gvs[SF SFY_ss] >> + qspecl_then [‘s2 with clock := s2.clock - 1’,‘env_e0’,‘env_e1’] + assume_tac big_clocked_total >> gvs[] >> + rename1 ‘evaluate _ _ _ _ (s3, res)’ >> + Cases_on ‘res’ >> gvs[SF SFY_ss] >> rename1 ‘Rval v'’ >> + Cases_on ‘update_thunk (REVERSE vs2 ++ [v] ++ l) s3.refs [v']’ >> gvs[SF SFY_ss] + ) >> Cases_on ‘op’ >> gs[opClass_cases, do_app_def] >> disj1_tac >> first_x_assum $ irule_at Any >> every_case_tac >> gvs[SF SFY_ss] ) + >- ( + Cases_on ‘dest_thunk [v] s.refs’ >> gvs[] >> + Cases_on ‘store_assign n (Thunk Evaluated v) s.refs’ >> gvs[] + ) >- ( Cases_on ‘do_log l v e’ >> gvs[] >> Cases_on ‘x’ >> gvs[] >> metis_tac[big_clocked_total] @@ -1933,7 +2283,7 @@ Proof qspecl_then [‘l0’,‘env’,‘s’] assume_tac big_clocked_list_total >> gvs[] >> PairCases_on ‘r’ >> Cases_on ‘r1’ >> gvs[SF SFY_ss] >> metis_tac[do_con_check_build_conv] - ) *) + ) QED Theorem evaluate_ctxts_T_total: diff --git a/semantics/alt_semantics/proofs/bigSmallInvariantsScript.sml b/semantics/alt_semantics/proofs/bigSmallInvariantsScript.sml index d4ebad4f95..06902a4028 100644 --- a/semantics/alt_semantics/proofs/bigSmallInvariantsScript.sml +++ b/semantics/alt_semantics/proofs/bigSmallInvariantsScript.sml @@ -42,7 +42,68 @@ Inductive evaluate_ctxt: ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v (s2 with <| ffi := new_ffi; refs := new_refs |>, res)) ∧ - ((~opClass op FunApp) ∧ + (opClass op Force ∧ + evaluate_list ck env s1 es (s2, Rval vs2) ∧ + (dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = BadRef ∨ + dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = NotThunk ∨ + (dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧ + do_opapp [f; Conv NONE []] = NONE)) + ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v + (s2, Rerr (Rabort Rtype_error))) ∧ + + (opClass op Force ∧ + evaluate_list ck env s1 es (s2, Rval vs2) ∧ + dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk Evaluated v' + ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v (s2, Rval v')) ∧ + + (opClass op Force ∧ + evaluate_list T env s1 es (s2, Rval vs2) ∧ + dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧ + do_opapp [f; Conv NONE []] = SOME env_e ∧ + s2.clock = 0 + ⇒ evaluate_ctxt T env s1 (Capp op vs1 () es) v + (s2, Rerr (Rabort Rtimeout_error))) ∧ + + (opClass op Force ∧ + evaluate_list ck env s1 es (s2, Rval vs2) ∧ + dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧ + do_opapp [f; Conv NONE []] = SOME (env', e) ∧ + (ck ⇒ s2.clock ≠ 0) ∧ + evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rerr err) + ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v + (s3, Rerr err)) ∧ + + (opClass op Force ∧ + evaluate_list ck env s1 es (s2, Rval vs2) ∧ + dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧ + do_opapp [f; Conv NONE []] = SOME (env', e) ∧ + (ck ⇒ s2.clock ≠ 0) ∧ + evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rval v') ∧ + update_thunk (REVERSE vs2 ++ [v] ++ vs1) s3.refs [v'] = NONE + ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v + (s3, Rerr (Rabort Rtype_error))) ∧ + + (opClass op Force ∧ + evaluate_list ck env s1 es (s2, Rval vs2) ∧ + dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧ + do_opapp [f; Conv NONE []] = SOME (env', e) ∧ + (ck ⇒ s2.clock ≠ 0) ∧ + evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rval v') ∧ + update_thunk (REVERSE vs2 ++ [v] ++ vs1) s3.refs [v'] = SOME refs + ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v + (s3 with refs := refs, Rval v')) ∧ + + (dest_thunk [v] s1.refs = BadRef ∨ + dest_thunk [v] s1.refs = IsThunk a b ∨ + (dest_thunk [v] s1.refs = NotThunk ∧ + store_assign loc (Thunk Evaluated v) s1.refs = NONE) + ⇒ evaluate_ctxt ck env s1 (Cforce loc) v (s1, Rerr (Rabort Rtype_error))) ∧ + + (dest_thunk [v] s1.refs = NotThunk ∧ + store_assign loc (Thunk Evaluated v) s1.refs = SOME refs + ⇒ evaluate_ctxt ck env s1 (Cforce loc) v (s1 with refs := refs, Rval v)) ∧ + + ((~opClass op FunApp ∧ ¬ opClass op Force) ∧ evaluate_list ck env s1 es (s2, Rval vs2) ∧ do_app (s2.refs, s2.ffi) op (REVERSE vs2 ++ [v] ++ vs1) = NONE ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v From 7790f622f5b055d485cfb03489c155e07d8d1b8f Mon Sep 17 00:00:00 2001 From: Hrutvik Kanabar Date: Mon, 1 Sep 2025 19:36:52 +0100 Subject: [PATCH 081/112] Update equivalence for small-step/ITree semantics --- .../alt_semantics/itree_semanticsScript.sml | 28 ++++++------ .../proofs/itree_semanticsEquivScript.sml | 43 ++++++++++++------- .../proofs/itree_semanticsPropsScript.sml | 18 ++++---- 3 files changed, 54 insertions(+), 35 deletions(-) diff --git a/semantics/alt_semantics/itree_semanticsScript.sml b/semantics/alt_semantics/itree_semanticsScript.sml index c26a754dd9..6000de91f0 100644 --- a/semantics/alt_semantics/itree_semanticsScript.sml +++ b/semantics/alt_semantics/itree_semanticsScript.sml @@ -410,15 +410,15 @@ Definition application_def: | NONE => Etype_error) | Force => (case vs of - [Loc _ n] => ( - case store_lookup n s of - SOME (Thunk Evaluated v) => - return env s v c - | SOME (Thunk NotEvaluated f) => - return env s f - ((Capp Opapp [Conv NONE []] [], env)::(Cforce n, env)::c) - | _ => Etype_error) - | _ => Etype_error) + [Loc b n] => ( + case dest_thunk [Loc b n] s of + | BadRef => Etype_error + | NotThunk => Etype_error + | IsThunk Evaluated v => return env s v c + | IsThunk NotEvaluated f => + return env s f + ((Capp Opapp [Conv NONE []] [], env)::(Cforce n, env)::c)) + | _ => Etype_error) | _ => case op of | FFI n => ( @@ -446,9 +446,13 @@ Definition continue_def: continue s v ((Capp op vs [], env) :: c) = application op env s (v::vs) c ∧ continue s v ((Capp op vs (e::es), env) :: c) = push env s e (Capp op (v::vs) es) c ∧ continue s v ((Cforce n, env) :: c) = ( - case store_assign n (Thunk Evaluated v) s of - SOME s' => return env s' v c - | NONE => Etype_error) ∧ + case dest_thunk [v] s of + | BadRef => Etype_error + | NotThunk => ( + case store_assign n (Thunk Evaluated v) s of + | SOME s' => return env s' v c + | NONE => Etype_error) + | IsThunk v3 v4 => Etype_error) ∧ continue s v ((Clog l e, env) :: c) = ( case do_log l v e of SOME (Exp e) => Estep (env, s, Exp e, c) diff --git a/semantics/alt_semantics/proofs/itree_semanticsEquivScript.sml b/semantics/alt_semantics/proofs/itree_semanticsEquivScript.sml index 27d5f0e5af..0edc1e831e 100644 --- a/semantics/alt_semantics/proofs/itree_semanticsEquivScript.sml +++ b/semantics/alt_semantics/proofs/itree_semanticsEquivScript.sml @@ -56,15 +56,18 @@ Theorem do_app_rel: (do_app st op vs) (OPTION_MAP (λ(a,b). (FST a, b)) (do_app (st, ffi) op vs)) Proof - cheat (* rw[] >> reverse $ Cases_on `do_app (st,ffi) op vs` >> gvs[] >- ( PairCases_on `x` >> gvs[semanticPrimitivesPropsTheory.do_app_cases] >> - simp[do_app_def, result_rel_cases] >> every_case_tac >> gvs[] + simp[do_app_def, result_rel_cases] >> every_case_tac >> gvs[] >> + gvs[semanticPrimitivesTheory.thunk_op_def, itree_semanticsTheory.thunk_op_def] >> + gvs[AllCaseEqs(), store_alloc_def] ) >> Cases_on `do_app st op vs` >> gvs[] >> PairCases_on `x` >> gvs[do_app_cases, semanticPrimitivesTheory.do_app_def, store_alloc_def] >> - every_case_tac >> gvs[] *) + every_case_tac >> gvs[] >> + gvs[semanticPrimitivesTheory.thunk_op_def, itree_semanticsTheory.thunk_op_def] >> + gvs[AllCaseEqs(), store_alloc_def] QED Theorem application_rel: @@ -74,25 +77,33 @@ Theorem application_rel: (application op env st vs cs1) (application op env (st,ffi) vs cs2) Proof - cheat (* rw[] >> drule do_app_rel >> disch_then $ qspecl_then [`vs`,`st`,`ffi`] assume_tac >> Cases_on ‘getOpClass op’ >- ( - Cases_on ‘op’ >> gs[getOpClass_def, application_def, cml_application_thm] >> + Cases_on ‘op’ >> gs[getOpClass_def, application_def, cml_application_thm] + >- gvs[AllCaseEqs()] >> simp[step_result_rel_cases, AllCaseEqs(), PULL_EXISTS] >> Cases_on ‘do_app (st,ffi) Eval vs’ >> gvs[] >> Cases_on ‘do_app st Eval vs’ >> gvs[] >> PairCases_on ‘x’ >> PairCases_on ‘x'’ >> gvs[result_rel_cases, SF smallstep_ss, SF itree_ss] >> gs[do_app_def, semanticPrimitivesTheory.do_app_def] >> every_case_tac >> - gs[]) + gs[] + ) >- ( rw[application_def, cml_application_thm] >> simp[step_result_rel_cases, AllCaseEqs(), PULL_EXISTS] >> Cases_on `do_opapp vs` >> simp[] >> PairCases_on `x` >> simp[] ) + >- ( + gvs[oneline getOpClass_def, AllCaseEqs()] >> + simp[application_thm, cml_application_thm] >> + rpt (TOP_CASE_TAC >> gvs[step_result_rel_cases]) >> + simp[return_def] >> gvs[ctxt_rel_def] >> + simp[ctxt_frame_rel_cases] + ) >- ( rw[application_def, cml_application_thm] >> Cases_on `do_app (st,ffi) op vs` >> gvs[] >> @@ -104,7 +115,8 @@ Proof gvs[result_rel_cases, SF smallstep_ss, SF itree_ss] >> gvs[step_result_rel_cases, AllCaseEqs(), ctxt_rel_def] >> simp[ctxt_frame_rel_cases] >> - gvs[do_app_def, AllCaseEqs(), store_alloc_def]) *) + gvs[do_app_def, thunk_op_def, AllCaseEqs(), store_alloc_def] + ) QED Theorem application_rel_FFI_type_error: @@ -187,7 +199,7 @@ Proof gvs[estep_def, step_result_rel_cases] >> strip_tac >> gvs[SF smallstep_ss, SF itree_ss, ctxt_rel_def, ctxt_frame_rel_cases, get_ffi_def] >> gvs[GSYM ctxt_frame_rel_cases, GSYM step_result_rel_cases] >> - CASE_TAC >- gvs[continue_def, get_ffi_def] >> + TOP_CASE_TAC >- gvs[continue_def, get_ffi_def] >> PairCases_on `h` >> gvs[] >> PairCases_on `x` >> gvs[] >> rename1 `ctxt_frame_rel c1 c2` >> rename1 `(c1,env)` >> rename1 `LIST_REL _ rest1 rest2` >> @@ -221,6 +233,7 @@ Proof >- (EVERY_CASE_TAC >> gvs[get_ffi_def, ctxt_frame_rel_cases]) >- (EVERY_CASE_TAC >> gvs[get_ffi_def, ctxt_frame_rel_cases]) >- (EVERY_CASE_TAC >> gvs[get_ffi_def, ctxt_frame_rel_cases]) + >- (EVERY_CASE_TAC >> gvs[get_ffi_def, ctxt_frame_rel_cases]) >- ( CASE_TAC >> simp[SF itree_ss] >> PairCases_on `h` >> simp[continue_def] >> @@ -474,14 +487,14 @@ Theorem step_result_rel_single_FFI_error: ⇒ ∃lnum env. estep ea = Effi s conf ws lnum env (FST $ SND ea) (TL $ SND $ SND $ SND $ ea) Proof - cheat (* rpt $ PairCases >> rw[e_step_def] >> gvs[AllCaseEqs(), SF smallstep_ss] >> - gvs[cml_application_thm, AllCaseEqs(), SF smallstep_ss] >> - gvs[semanticPrimitivesPropsTheory.do_app_cases, AllCaseEqs()] >> + gvs[cml_application_thm, AllCaseEqs(), SF smallstep_ss, thunk_op_def] >> + gvs[semanticPrimitivesPropsTheory.do_app_cases, + semanticPrimitivesTheory.thunk_op_def, AllCaseEqs()] >> gvs[step_result_rel_cases, ctxt_rel_def] >> gvs[GSYM ctxt_rel_def, ctxt_frame_rel_cases] >> pairarg_tac >> gvs[] >> simp[SF itree_ss, application_def] >> gvs[call_FFI_def, AllCaseEqs()] >> - simp[combinTheory.o_DEF, stringTheory.IMPLODE_EXPLODE_I] *) + simp[combinTheory.o_DEF, stringTheory.IMPLODE_EXPLODE_I] QED Theorem dstep_result_rel_single_FFI_strong: @@ -791,12 +804,12 @@ Theorem do_app_not_SharedMem: SOME (v, Rerr (Rabort (Rffi_error (Final_event (SharedMem s') conf ws outcome)))) Proof - cheat (* rpt strip_tac >> gvs[DefnBase.one_line_ify NONE semanticPrimitivesTheory.do_app_def, - AllCaseEqs(),call_FFI_def] >> + AllCaseEqs(),call_FFI_def,store_alloc_def, + semanticPrimitivesTheory.thunk_op_def] >> rw[] >> - pairarg_tac >> fs[] *) + pairarg_tac >> fs[] QED Theorem application_not_SharedMem: diff --git a/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml b/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml index e7cea7581c..a3e2353d97 100644 --- a/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml +++ b/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml @@ -66,6 +66,7 @@ Inductive ctxt_frame_rel: ctxt_frame_rel Craise (Craise ()) ∧ ctxt_frame_rel (Chandle pes) (Chandle () pes) ∧ ctxt_frame_rel (Capp op vs es) (Capp op vs () es) ∧ + ctxt_frame_rel (Cforce n) (Cforce n) ∧ ctxt_frame_rel (Clog lop e) (Clog lop () e) ∧ ctxt_frame_rel (Cif e1 e2) (Cif () e1 e2) ∧ ctxt_frame_rel (Cmat_check pes v) (Cmat_check () pes v) ∧ @@ -542,14 +543,15 @@ Theorem application_thm: else (case getOpClass op of | Force => (case vs of - [Loc _ n] => ( - case store_lookup n s of - SOME (Thunk Evaluated v) => - return env s v c - | SOME (Thunk NotEvaluated f) => - return env s f ((Capp Opapp [Conv NONE []] [], env)::(Cforce n, env)::c) - | _ => Etype_error) - | _ => Etype_error) + [Loc b n] => ( + case dest_thunk [Loc b n] s of + | BadRef => Etype_error + | NotThunk => Etype_error + | IsThunk Evaluated v => return env s v c + | IsThunk NotEvaluated f => + return env s f + ((Capp Opapp [Conv NONE []] [], env)::(Cforce n, env)::c)) + | _ => Etype_error) | _ => case do_app s op vs of | NONE => Etype_error From e0792746e854eb7f54f6b9f66ba0312f490ed8b9 Mon Sep 17 00:00:00 2001 From: Hrutvik Kanabar Date: Mon, 1 Sep 2025 21:51:17 +0100 Subject: [PATCH 082/112] Fix `source_evalProofTheory` --- .../backend/proofs/source_evalProofScript.sml | 140 ++++++++++++------ 1 file changed, 91 insertions(+), 49 deletions(-) diff --git a/compiler/backend/proofs/source_evalProofScript.sml b/compiler/backend/proofs/source_evalProofScript.sml index d2aa0ad1d9..1326f9a9c2 100644 --- a/compiler/backend/proofs/source_evalProofScript.sml +++ b/compiler/backend/proofs/source_evalProofScript.sml @@ -1026,12 +1026,13 @@ Proof \\ simp [state_component_equality]) >- ( gvs [oneline dest_thunk_def, AllCaseEqs(), oneline store_lookup_def] + \\ simp[PULL_EXISTS] \\ gvs [s_rel_def, LIST_REL_EL_EQN] \\ `∃a. EL n refs'' = Thunk NotEvaluated a ∧ v_rel orac_s'' v a` by ( first_x_assum drule \\ rw [] \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs [] - \\ simp [state_component_equality]) + \\ gvs[do_opapp_cases] \\ irule_at Any EQ_REFL >> simp[]) >- ( gvs [oneline dest_thunk_def, AllCaseEqs(), oneline store_lookup_def] \\ `n < LENGTH t''.refs ∧ @@ -1039,44 +1040,67 @@ Proof v_rel (orac_s t''.eval_state) v a` by ( gvs [s_rel_def, LIST_REL_EL_EQN] \\ first_x_assum drule \\ rw [] - \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs [] - \\ drule_then assume_tac s_rel_clock \\ gvs [dec_clock_def] - \\ last_x_assum $ drule_then assume_tac - \\ pop_assum $ qspec_then `sing_env "f" a` assume_tac \\ gvs [] - \\ pop_assum mp_tac \\ impl_tac - >- ( - rw [env_rel_def, sing_env_def, namespaceTheory.nsEmpty_def] - \\ Cases_on `nm` - \\ gvs [namespaceTheory.nsLookup_def, namespaceTheory.nsBind_def]) - \\ rw [] \\ gvs [abort_def] - \\ simp [PULL_EXISTS] - \\ gvs [es_forward_def, es_stack_forward_def] - \\ gvs [oneline update_thunk_def, AllCaseEqs()] - \\ gvs [oneline store_assign_def] \\ rw [] - >- ( - gvs [oneline dest_thunk_def] - \\ qpat_x_assum `v_rel _ v'' y` mp_tac - \\ Cases_on `v''` \\ Cases_on `y` \\ rw [Once v_rel_cases] + \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs [] >> + gvs[do_opapp_cases, PULL_EXISTS] >- ( - gvs [oneline store_v_same_type_def] - \\ gvs [oneline store_lookup_def] - \\ gvs [s_rel_def, LIST_REL_EL_EQN] - \\ IF_CASES_TAC \\ gvs [] - \\ first_x_assum drule \\ rw [] - \\ Cases_on `EL n' st2.refs` \\ Cases_on `EL n' refs'4'` - \\ gvs [sv_rel_def] - \\ Cases_on `t` \\ gvs []) - >- gvs [v_to_env_id_def]) - >- gvs [s_rel_def, LIST_REL_EL_EQN] - >- ( - gvs [oneline store_v_same_type_def] - \\ gvs [s_rel_def, LIST_REL_EL_EQN] - \\ first_x_assum drule \\ rw [] - \\ Cases_on `EL n st2.refs` \\ Cases_on `EL n refs'4'` - \\ gvs [sv_rel_def]) - >- ( - gvs [s_rel_def, state_component_equality, LIST_REL_EL_EQN, EL_LUPDATE] - \\ rw [])) + imp_res_tac s_rel_def >> gvs[] >> + drule s_rel_clock >> simp[dec_clock_def] >> strip_tac >> + last_x_assum dxrule >> simp[] >> + qmatch_goalsub_abbrev_tac ‘evaluate _ new_env’ >> + disch_then $ qspec_then ‘new_env’ mp_tac >> impl_tac + >- (unabbrev_all_tac >> irule env_rel_add_nsBind >> simp[]) >> + strip_tac >> gvs[] >> + gvs[oneline update_thunk_def, AllCaseEqs()] >> + gvs[store_assign_def, s_rel_def, state_component_equality] >> + reverse $ rw[] >> insts_tac + >- (irule EVERY2_LUPDATE_same >> gvs[]) + >- ( + gvs[LIST_REL_EL_EQN, store_v_same_type_def] >> + first_x_assum drule >> simp[sv_rel_cases] >> + strip_tac >> gvs[] + ) + >- gvs[LIST_REL_EL_EQN] >> + qpat_x_assum ‘dest_thunk _ _ = _’ mp_tac >> simp[oneline dest_thunk_def] >> + qpat_x_assum ‘v_rel _ _ _’ mp_tac >> simp[Once v_rel_cases] >> strip_tac >> gvs[] + >- gvs[oneline v_to_env_id_def, AllCaseEqs()] >> + simp[store_lookup_def] >> gvs[LIST_REL_EL_EQN] >> + IF_CASES_TAC >> gvs[] >> + first_x_assum drule >> simp[sv_rel_cases] >> strip_tac >> gvs[] >> + TOP_CASE_TAC >> gvs[] + ) + >- ( + imp_res_tac s_rel_def >> gvs[] >> + drule s_rel_clock >> simp[dec_clock_def] >> strip_tac >> + last_x_assum dxrule >> simp[] >> + qmatch_goalsub_abbrev_tac ‘evaluate _ new_env’ >> + disch_then $ qspec_then ‘new_env’ mp_tac >> impl_tac + >- ( + unabbrev_all_tac >> simp[build_rec_env_merge, nsAppend_to_nsBindList] >> + irule env_rel_add_nsBind >> simp[] >> + irule env_rel_add_nsBindList >> + simp[LIST_REL_MAP1, SRULE [SF ETA_ss] LIST_REL_MAP2, ELIM_UNCURRY] >> + simp[LIST_REL_EL_EQN] + ) >> + strip_tac >> gvs[] >> + gvs[oneline update_thunk_def, AllCaseEqs()] >> + gvs[store_assign_def, s_rel_def, state_component_equality] >> + reverse $ rw[] >> insts_tac + >- (irule EVERY2_LUPDATE_same >> gvs[]) + >- ( + gvs[LIST_REL_EL_EQN, store_v_same_type_def] >> + first_x_assum drule >> simp[sv_rel_cases] >> + strip_tac >> gvs[] + ) + >- gvs[LIST_REL_EL_EQN] >> + qpat_x_assum ‘dest_thunk _ _ = _’ mp_tac >> simp[oneline dest_thunk_def] >> + qpat_x_assum ‘v_rel _ _ _’ mp_tac >> simp[Once v_rel_cases] >> strip_tac >> gvs[] + >- gvs[oneline v_to_env_id_def, AllCaseEqs()] >> + simp[store_lookup_def] >> gvs[LIST_REL_EL_EQN] >> + IF_CASES_TAC >> gvs[] >> + first_x_assum drule >> simp[sv_rel_cases] >> strip_tac >> gvs[] >> + TOP_CASE_TAC >> gvs[] + ) + ) >- ( gvs [oneline dest_thunk_def, AllCaseEqs(), oneline store_lookup_def] \\ `n < LENGTH t''.refs ∧ @@ -1084,17 +1108,35 @@ Proof v_rel (orac_s t''.eval_state) v a` by ( gvs [s_rel_def, LIST_REL_EL_EQN] \\ first_x_assum drule \\ rw [] - \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs [] - \\ drule_then assume_tac s_rel_clock \\ gvs [dec_clock_def] - \\ last_x_assum $ drule_then assume_tac - \\ pop_assum $ qspec_then `sing_env "f" a` assume_tac \\ gvs [] - \\ pop_assum mp_tac \\ impl_tac - >- ( - rw [env_rel_def, sing_env_def, namespaceTheory.nsEmpty_def] - \\ Cases_on `nm` - \\ gvs [namespaceTheory.nsLookup_def, namespaceTheory.nsBind_def]) - \\ rw [] \\ gvs [abort_def] - \\ gvs [es_forward_def, es_stack_forward_def])) + \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs [] >> + irule_at Any OR_INTRO_THM2 >> + gvs[do_opapp_cases, PULL_EXISTS] + >- ( + imp_res_tac s_rel_def >> gvs[] >> + drule s_rel_clock >> simp[dec_clock_def] >> strip_tac >> + last_x_assum dxrule >> simp[] >> + qmatch_goalsub_abbrev_tac ‘evaluate _ new_env’ >> + disch_then $ qspec_then ‘new_env’ mp_tac >> impl_tac + >- (unabbrev_all_tac >> irule env_rel_add_nsBind >> simp[]) >> + strip_tac >> gvs[] >> insts_tac + ) + >- ( + imp_res_tac s_rel_def >> gvs[] >> + drule s_rel_clock >> simp[dec_clock_def] >> strip_tac >> + last_x_assum dxrule >> simp[] >> + qmatch_goalsub_abbrev_tac ‘evaluate _ new_env’ >> + disch_then $ qspec_then ‘new_env’ mp_tac >> impl_tac + >- ( + unabbrev_all_tac >> simp[build_rec_env_merge, nsAppend_to_nsBindList] >> + irule env_rel_add_nsBind >> simp[] >> + irule env_rel_add_nsBindList >> + simp[LIST_REL_MAP1, SRULE [SF ETA_ss] LIST_REL_MAP2, ELIM_UNCURRY] >> + simp[LIST_REL_EL_EQN] + ) >> + strip_tac >> gvs[] >> insts_tac + ) + ) + ) \\ eval_cases_tac \\ drule_then (drule_then assume_tac) do_app_sim \\ insts_tac From 4c4d8cc2bab040d210c706b9b84bc6d58316e234 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Tue, 2 Sep 2025 11:28:00 +0300 Subject: [PATCH 083/112] fix `ml_optimise` --- translator/ml_optimiseScript.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/translator/ml_optimiseScript.sml b/translator/ml_optimiseScript.sml index 6071b8af1d..7e2f0d17af 100644 --- a/translator/ml_optimiseScript.sml +++ b/translator/ml_optimiseScript.sml @@ -189,7 +189,7 @@ Proof \\ disch_then (qspec_then `st1.clock` assume_tac) \\ asm_exists_tac \\ fs [] \\ gvs [AllCaseEqs(), dec_clock_def, PULL_EXISTS] >- metis_tac [] - \\ qpat_x_assum `evaluate _ (sing_env _ _) _ = _` assume_tac + \\ qpat_x_assum `evaluate _ env' _ = _` assume_tac \\ drule evaluate_add_to_clock \\ rw [] \\ metis_tac []) THEN1 (* App Simple *) From 8024f6caa1f78156efd52a392c26945cf74b5327 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 4 Sep 2025 22:37:44 +0300 Subject: [PATCH 084/112] Some progress on `dat_to_wordProof` --- compiler/backend/data_to_wordScript.sml | 21 +- .../proofs/data_to_wordProofScript.sml | 198 +++++++++++++----- .../proofs/data_to_word_memoryProofScript.sml | 16 -- 3 files changed, 152 insertions(+), 83 deletions(-) diff --git a/compiler/backend/data_to_wordScript.sml b/compiler/backend/data_to_wordScript.sml index 89d7708c2d..9d351e09b2 100644 --- a/compiler/backend/data_to_wordScript.sml +++ b/compiler/backend/data_to_wordScript.sml @@ -2431,27 +2431,26 @@ Definition force_thunk_def: | SOME (dest,_) => Assign (adjust_var dest) (Var (adjust_var v1))) (list_Seq [Assign 1 (real_addr c (adjust_var v1)); - Assign 3 (Op And [Load (Var 1); Const 0b1111w]); - If Equal 3 (Imm (n2w (8 + 6))) + Assign 3 (Op And [Load (Var 1); Const 0b111100w]); + If Equal 3 (Imm (n2w ((8 + 6) * 4))) (dtcase ret of | NONE => list_Seq - [Assign 1 (Op And [Load (Op Add [Var 1; Const bytes_in_word])]); + [Assign 1 (Load (Op Add [Var 1; Const bytes_in_word])); Return 0 [1]] | SOME (dest,_) => Assign (adjust_var dest) - (Op And [Load (Op Add [Var 1; Const bytes_in_word])])) $ - If NotEqual 3 (Imm (n2w (0 + 6))) + (Load (Op Add [Var 1; Const bytes_in_word]))) $ + If NotEqual 3 (Imm (n2w ((0 + 6) * 4))) (dtcase ret of | NONE => Return 0 [adjust_var v1] | SOME (dest,_) => Assign (adjust_var dest) (Var (adjust_var v1))) (list_Seq - [Assign 5 (Op And [Load (Op Add [Var 1; Const bytes_in_word])]); - Call - (dtcase ret of - | NONE => NONE - | SOME (r,ns) => SOME ([r],adjust_sets ns,Skip,secn,l)) - (SOME loc) [adjust_var v1; 5] NONE])]),l+1) + [Assign 5 (Load (Op Add [Var 1; Const bytes_in_word])); + (dtcase ret of + | NONE => Call NONE (SOME loc) [0; adjust_var v1; 5] NONE + | SOME (r,ns) => Call (SOME ([r],adjust_sets ns,Skip,secn,l)) + (SOME loc) [adjust_var v1; 5] NONE)])]),l+1) : 'a wordLang$prog # num End diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml index 4edb3d4331..02f19ffade 100644 --- a/compiler/backend/proofs/data_to_wordProofScript.sml +++ b/compiler/backend/proofs/data_to_wordProofScript.sml @@ -50,17 +50,18 @@ Proof \\ gvs[do_space_def,AllCaseEqs(),consume_space_def] QED -Theorem memory_rel_Force_Evaluated: +Theorem memory_rel_Force: memory_rel c be ts refs sp st m dm ((RefPtr bl nn,ptr)::vars) /\ - lookup nn refs = SOME (Thunk Evaluated v) /\ + lookup nn refs = SOME (Thunk ev v) /\ good_dimindex (:'a) ==> ?ptr_w x:'a word w w'. ptr = Word ptr_w /\ get_real_addr c st ptr_w = SOME x /\ x IN dm /\ m x = Word w /\ (x + bytes_in_word) IN dm /\ - (15w && w = 14w) (* cheated *) /\ - m (x + bytes_in_word) = Word w' (* cheated *) /\ + (case ev of + | Evaluated => 0b111100w && w = n2w ((8 + 6) * 4) + | NotEvaluated => 0b111100w && w = n2w ((0 + 6) * 4)) (* cheated *) /\ memory_rel c be ts refs sp st m dm ((v,m (x + bytes_in_word))::(RefPtr bl nn,ptr)::vars) Proof @@ -90,6 +91,43 @@ Proof \\ cheat QED +Theorem state_rel_call_env_get_var: + get_var src s.locals = SOME (RefPtr v0 ptr) /\ + get_var (adjust_var src) (t:('a,'c,'ffi) wordSem$state) = SOME w /\ + state_rel c l1 l2 s t [] locs ==> + state_rel c l1 l2 (call_env [RefPtr v0 ptr; a] ss (dec_clock s)) + (call_env [Loc l1 l2; w; t.memory w'] ss (dec_clock t)) [] locs +Proof + full_simp_tac(srw_ss())[state_rel_def,call_env_def,wordSemTheory.call_env_def,LET_THM, + dataSemTheory.dec_clock_def,wordSemTheory.dec_clock_def,lookup_adjust_var_fromList2] + \\ srw_tac[][lookup_fromList2,lookup_fromList] \\ srw_tac[][] + \\ imp_res_tac get_vars_IMP_LENGTH + \\ imp_res_tac wordPropsTheory.get_vars_length_lemma \\ full_simp_tac(srw_ss())[] + \\ imp_res_tac stack_rel_IMP_size_of_stack \\ fs [] + THEN1 + (Cases_on `s.stack_max` \\ fs [OPTION_MAP2_DEF] + \\ Cases_on `ss` \\ fs [OPTION_MAP2_DEF] + \\ Cases_on `size_of_stack s.stack` \\ fs [OPTION_MAP2_DEF] + \\ Cases_on `t.stack_max` \\ fs [OPTION_MAP2_DEF]) + THEN1 + (Cases_on `s.stack_max` \\ fs [OPTION_MAP2_DEF] + \\ Cases_on `ss` \\ fs [OPTION_MAP2_DEF] + \\ Cases_on `size_of_stack s.stack` \\ fs [OPTION_MAP2_DEF] + \\ Cases_on `t.stack_max` \\ fs [OPTION_MAP2_DEF]) + \\ asm_exists_tac + \\ full_simp_tac bool_ss [GSYM APPEND_ASSOC] + \\ imp_res_tac word_ml_inv_get_var_IMP + \\ first_assum (fn th => mp_tac th THEN match_mp_tac word_ml_inv_rearrange) + \\ full_simp_tac(srw_ss())[MEM] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] + \\ Cases_on `x` \\ full_simp_tac(srw_ss())[join_env_def,MEM_MAP,MEM_FILTER] + \\ Cases_on `y` \\ full_simp_tac(srw_ss())[MEM_toAList,lookup_inter_alt] \\ srw_tac[][MEM_ZIP] + \\ full_simp_tac(srw_ss())[lookup_fromList2,lookup_fromList] + \\ rpt disj1_tac + \\ Q.MATCH_ASSUM_RENAME_TAC `EVEN k` + \\ full_simp_tac(srw_ss())[DIV_LT_X] + \\ cheat +QED + Theorem data_compile_correct: !prog s c n l l1 l2 res s1 (t:('a,'c,'ffi)wordSem$state) locs. (dataSem$evaluate (prog,s) = (res,s1)) /\ @@ -166,51 +204,49 @@ Proof \\ fs [cut_state_def,cut_env_def] \\ every_case_tac \\ fs [] \\ rw [] \\ fs [set_var_def]) >~ [‘evaluate (Force _ _ _,s)’] >- ( - simp [comp_def] - \\ gvs [dataSemTheory.evaluate_def] + gvs [evaluate_def] \\ Cases_on `get_var src s.locals` \\ gvs [] \\ Cases_on `dest_thunk x s.refs` \\ gvs [] - \\ Cases_on `t'` \\ gvs [] + \\ simp [comp_def, force_thunk_def] + \\ TOP_CASE_TAC \\ gvs [] >- ( - imp_res_tac state_rel_get_var_IMP - \\ `∃v0 ptr. get_var src s.locals = SOME (RefPtr v0 ptr)` - by gvs [oneline dest_thunk_def, AllCaseEqs()] - \\ drule_all state_rel_get_var_RefPtr \\ rw [] \\ gvs [] - \\ imp_res_tac state_rel_cut_env \\ gvs [] - \\ gvs [state_rel_thm, oneline dest_thunk_def] - \\ Cases_on `lookup ptr s.refs` \\ gvs [] - \\ Cases_on `x` \\ gvs [] - \\ Cases_on `t'` \\ gvs [] - \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] - \\ drule_all memory_rel_get_var_IMP - \\ qpat_x_assum `memory_rel _ _ _ _ _ _ _ _ _` kall_tac \\ rw [] - \\ simp [force_thunk_def, wordSemTheory.evaluate_def] - \\ TOP_CASE_TAC \\ gvs [] - >- ( - fs[encode_header_def] - \\ fs[encode_header_def, state_rel_def, good_dimindex_def, limits_inv_def, - dimword_def, memory_rel_def, heap_in_memory_store_def, - consume_space_def, arch_size_def] - \\ rfs[NOT_LESS]) - \\ drule memory_rel_Force_Evaluated \\ rw [] \\ gvs [] - \\ simp [wordSemTheory.evaluate_def, wordSemTheory.get_var_imm_def, - word_cmp_Test_1, word_bit_def, get_addr_0] - \\ simp [list_Seq_def, wordSemTheory.evaluate_def] - \\ `word_exp t (real_addr c (adjust_var src)) = SOME (Word x')` - by metis_tac [get_real_addr_lemma] \\ gvs [] - \\ gvs [wordSemTheory.set_var_def, wordSemTheory.word_exp_def, - wordSemTheory.get_var_def, wordSemTheory.mem_load_def, - wordSemTheory.the_words_def, word_op_def, - wordSemTheory.get_var_imm_def, asmTheory.word_cmp_def] + fs[encode_header_def] + \\ fs[encode_header_def, state_rel_def, good_dimindex_def, limits_inv_def, + dimword_def, memory_rel_def, heap_in_memory_store_def, + consume_space_def, arch_size_def] + \\ rfs[NOT_LESS]) + \\ simp [wordSemTheory.evaluate_def] + \\ `∃v0 ptr. get_var src s.locals = SOME (RefPtr v0 ptr)` + by gvs [oneline dest_thunk_def, AllCaseEqs()] + \\ drule_all state_rel_get_var_RefPtr \\ rw [] \\ gvs [] + \\ simp [wordSemTheory.get_var_imm_def, word_cmp_Test_1, word_bit_def, + get_addr_0] + \\ simp [list_Seq_def, wordSemTheory.evaluate_def] + \\ gvs [dest_thunk_def] + \\ Cases_on `lookup ptr s.refs` \\ gvs [] + \\ Cases_on `x` \\ gvs [] + \\ qpat_assum `state_rel _ _ _ _ _ _ _` mp_tac + \\ pure_rewrite_tac [state_rel_thm] \\ rw [] + \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] + \\ drule_all memory_rel_get_var_IMP \\ rw [] \\ gvs [] + \\ drule_all memory_rel_Force \\ rw [] \\ gvs [] + \\ `word_exp t (real_addr c (adjust_var src)) = SOME (Word x)` + by metis_tac [get_real_addr_lemma] \\ gvs [] + \\ simp [wordSemTheory.set_var_def, wordSemTheory.word_exp_def, + wordSemTheory.get_var_def, wordSemTheory.mem_load_def, + wordSemTheory.the_words_def, word_op_def, lookup_insert] + \\ simp [wordSemTheory.get_var_imm_def] + \\ Cases_on `t''` \\ gvs [] + >- ( + simp [asmTheory.word_cmp_def] \\ Cases_on `ret` \\ gvs [] >- ( - simp [wordSemTheory.evaluate_def, wordSemTheory.set_var_def, - wordSemTheory.word_exp_def, wordSemTheory.get_var_def, - lookup_insert, wordSemTheory.the_words_def, - word_op_def, wordSemTheory.mem_load_def] - \\ gvs [lookup_insert, wordSemTheory.get_vars_def, - wordSemTheory.get_var_def, flush_state_def, - wordSemTheory.flush_state_def] + simp [wordSemTheory.evaluate_def] + \\ simp [wordSemTheory.word_exp_def, wordSemTheory.get_var_def, + lookup_insert, wordSemTheory.the_words_def, word_op_def, + wordSemTheory.mem_load_def, wordSemTheory.get_vars_def, + wordSemTheory.set_var_def] + \\ simp [flush_state_def, wordSemTheory.flush_state_def] \\ conj_tac >- (imp_res_tac option_le_add_indv) \\ simp [join_env_def] @@ -218,25 +254,75 @@ Proof mp_tac th THEN match_mp_tac memory_rel_rearrange) \\ rw [] \\ gvs []) \\ Cases_on `x''` \\ gvs [] + \\ simp [wordSemTheory.evaluate_def] + \\ simp [wordSemTheory.word_exp_def, wordSemTheory.get_var_def, + lookup_insert, wordSemTheory.the_words_def, word_op_def, + wordSemTheory.mem_load_def, wordSemTheory.set_var_def] \\ Cases_on `cut_env r s.locals` \\ gvs [] - \\ simp [wordSemTheory.evaluate_def, wordSemTheory.word_exp_def, - wordSemTheory.get_var_def, lookup_insert, - wordSemTheory.the_words_def, word_op_def, - wordSemTheory.mem_load_def] - \\ gvs [wordSemTheory.set_var_def, set_var_def, lookup_insert] - \\ rw [] - >- (first_x_assum $ drule_at (Pat `cut_env _ _ = _`) \\ rw []) + \\ simp [set_var_def] + \\ drule_all state_rel_cut_env \\ rw [] + >- ( + IF_CASES_TAC \\ gvs [] + \\ gvs [state_rel_thm, lookup_insert, adjust_var_11]) \\ gvs [inter_insert_ODD_adjust_set] \\ pure_rewrite_tac [GSYM APPEND_ASSOC] \\ irule memory_rel_insert \\ gvs [] + \\ gvs [state_rel_thm] \\ first_x_assum (fn th => mp_tac th THEN match_mp_tac memory_rel_rearrange) \\ rw [] \\ gvs [] - \\ ntac 2 disj2_tac \\ ntac 2 disj1_tac \\ gvs [] - \\ gvs [join_env_def, MEM_MAP, MEM_FILTER] - \\ rpt (pairarg_tac \\ gvs []) - \\ qexists `(n,v)` \\ gvs [] - \\ gvs [MEM_toAList,lookup_inter_alt,lookup_insert,AllCaseEqs()] + \\ cheat) + \\ `¬word_cmp Equal 24w 56w` by cheat \\ gvs [] + \\ simp [asmTheory.word_cmp_def] + \\ simp [wordSemTheory.get_vars_def, wordSemTheory.get_var_def, + lookup_insert] + \\ simp [GSYM wordSemTheory.get_var_def] + \\ simp [wordSemTheory.bad_dest_args_def] + \\ Cases_on `s.clock = 0` \\ gvs [] >- cheat + \\ Cases_on `find_code (SOME loc) [RefPtr v0 ptr; a] s.code + s.stack_frame_sizes` \\ gvs [] + \\ Cases_on `x''` \\ gvs [] + \\ Cases_on `r` \\ gvs [] + \\ Cases_on `ret` \\ gvs [] + >- ( + Cases_on `evaluate (q',call_env q r' (dec_clock s))` \\ gvs [] + \\ Cases_on `q''` \\ gvs [] + \\ simp [wordSemTheory.evaluate_def, wordSemTheory.get_vars_def, + wordSemTheory.get_var_def, lookup_insert] + \\ gvs [wordSemTheory.get_var_def] + \\ simp [wordSemTheory.bad_dest_args_def, wordSemTheory.add_ret_loc_def] + \\ gvs [find_code_def] + \\ Cases_on `lookup loc s.code` \\ gvs [] + \\ Cases_on `x'''` \\ gvs [] + \\ simp [wordSemTheory.find_code_def] + \\ gvs [code_rel_def] + \\ first_x_assum $ drule_at (Pat `lookup _ s.code = _`) \\ rw [] + \\ gvs [GSYM wordSemTheory.get_var_def] + \\ `state_rel c l1 l2 s + (t with locals := insert 5 (t.memory (x + bytes_in_word)) + (insert 3 (Word 24w) + (insert 1 (Word x) t.locals))) [] locs` by ( + fs [state_rel_def] \\ srw_tac[][] + \\ fs [lookup_insert,adjust_var_NEQ_1] + \\ asm_exists_tac \\ fs [] + \\ fs [inter_insert,domain_lookup, + lookup_3_adjust_set,lookup_1_adjust_set,lookup_5_adjust_set]) + \\ drule_at (Pat `state_rel _ _ _ _ _ _ _`) state_rel_call_env_get_var + \\ disch_then drule + \\ simp [wordSemTheory.get_var_def, lookup_insert] + \\ simp [GSYM wordSemTheory.get_var_def] + \\ disch_then + $ qspecl_then [`(x + bytes_in_word)`, `lookup loc s.stack_frame_sizes`, `a`] + assume_tac \\ gvs [] + \\ last_x_assum drule \\ simp [call_env_def] + \\ disch_then $ qspecl_then [`loc`, `2`] assume_tac \\ gvs [] + \\ Cases_on `res1` \\ gvs [] + \\ Cases_on `x'''` \\ gvs [] + >- ( + Cases_on `x''` \\ gvs [] + \\ gvs [state_rel_thm, wordSemTheory.get_var_def, code_rel_def]) + \\ Cases_on `x''` \\ gvs [] + \\ Cases_on `e` \\ gvs [] \\ cheat) \\ cheat) >~ [‘evaluate (Tick,s)’] >- diff --git a/compiler/backend/proofs/data_to_word_memoryProofScript.sml b/compiler/backend/proofs/data_to_word_memoryProofScript.sml index 2ed1798de5..1293d3942b 100644 --- a/compiler/backend/proofs/data_to_word_memoryProofScript.sml +++ b/compiler/backend/proofs/data_to_word_memoryProofScript.sml @@ -6391,22 +6391,6 @@ Proof \\ fs [encode_header_def,AC STAR_ASSOC STAR_COMM,thunk_tag_bits_lemma] QED -(*Theorem memory_rel_Thunk_IMP: - memory_rel c be ts refs sp st m dm ((RefPtr bl nn,ptr)::vars) /\ - lookup nn refs = SOME (Thunk ev v) /\ - good_dimindex (:'a) ==> - ?ptr_w x:'a word. - ptr = Word ptr_w /\ - get_real_addr c st ptr_w = SOME x /\ - x IN dm /\ (x + bytes_in_word) IN dm /\ - (ev = Evaluated ⇒ (m x && 0x111100b) = n2w (8 + 6) * 2w) /\ - (ev = NotEvaluated ⇒ (m x && 0x111100b) = n2w (0 + 6) * 2w) /\ - memory_rel c be ts refs sp st m dm - ((v,m (x + bytes_in_word))::(RefPtr bl nn,ptr)::vars) -Proof - cheat -QED*) - Theorem word_list_exists_thm: (word_list_exists a 0 = emp) /\ (word_list_exists a (SUC n) = From 9f6aa13eec589bd33c9b18c88977b25c98c3b8ad Mon Sep 17 00:00:00 2001 From: Hrutvik Kanabar Date: Sun, 7 Sep 2025 13:39:43 +0100 Subject: [PATCH 085/112] Fix `source_to_flatProofTheory` --- .../backend/proofs/source_evalProofScript.sml | 36 +++++- .../proofs/source_to_flatProofScript.sml | 112 +++++++++--------- semantics/evaluateScript.sml | 7 +- semantics/proofs/evaluatePropsScript.sml | 3 +- 4 files changed, 92 insertions(+), 66 deletions(-) diff --git a/compiler/backend/proofs/source_evalProofScript.sml b/compiler/backend/proofs/source_evalProofScript.sml index 1326f9a9c2..d0fc6e4f50 100644 --- a/compiler/backend/proofs/source_evalProofScript.sml +++ b/compiler/backend/proofs/source_evalProofScript.sml @@ -1033,6 +1033,18 @@ Proof first_x_assum drule \\ rw [] \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs [] \\ gvs[do_opapp_cases] \\ irule_at Any EQ_REFL >> simp[]) + >- ( + gvs [oneline dest_thunk_def, AllCaseEqs(), oneline store_lookup_def] + \\ `n < LENGTH t''.refs ∧ + ∃a. EL n t''.refs = Thunk NotEvaluated a ∧ + v_rel (orac_s t''.eval_state) v a` by ( + gvs [s_rel_def, LIST_REL_EL_EQN] + \\ first_x_assum drule \\ rw [] + \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs [] >> + gvs[do_opapp_cases, PULL_EXISTS] >> + imp_res_tac s_rel_def >> gvs[] >> + drule s_rel_clock >> simp[dec_clock_def] >> strip_tac + ) >- ( gvs [oneline dest_thunk_def, AllCaseEqs(), oneline store_lookup_def] \\ `n < LENGTH t''.refs ∧ @@ -1045,6 +1057,7 @@ Proof >- ( imp_res_tac s_rel_def >> gvs[] >> drule s_rel_clock >> simp[dec_clock_def] >> strip_tac >> + dxrule s_rel_clock >> simp[dec_clock_def] >> strip_tac >> last_x_assum dxrule >> simp[] >> qmatch_goalsub_abbrev_tac ‘evaluate _ new_env’ >> disch_then $ qspec_then ‘new_env’ mp_tac >> impl_tac @@ -1071,6 +1084,7 @@ Proof >- ( imp_res_tac s_rel_def >> gvs[] >> drule s_rel_clock >> simp[dec_clock_def] >> strip_tac >> + dxrule s_rel_clock >> simp[dec_clock_def] >> strip_tac >> last_x_assum dxrule >> simp[] >> qmatch_goalsub_abbrev_tac ‘evaluate _ new_env’ >> disch_then $ qspec_then ‘new_env’ mp_tac >> impl_tac @@ -1109,11 +1123,12 @@ Proof gvs [s_rel_def, LIST_REL_EL_EQN] \\ first_x_assum drule \\ rw [] \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs [] >> - irule_at Any OR_INTRO_THM2 >> gvs[do_opapp_cases, PULL_EXISTS] >- ( imp_res_tac s_rel_def >> gvs[] >> + irule_at Any OR_INTRO_THM2 >> drule s_rel_clock >> simp[dec_clock_def] >> strip_tac >> + dxrule s_rel_clock >> simp[dec_clock_def] >> strip_tac >> last_x_assum dxrule >> simp[] >> qmatch_goalsub_abbrev_tac ‘evaluate _ new_env’ >> disch_then $ qspec_then ‘new_env’ mp_tac >> impl_tac @@ -1122,7 +1137,9 @@ Proof ) >- ( imp_res_tac s_rel_def >> gvs[] >> + irule_at Any OR_INTRO_THM2 >> drule s_rel_clock >> simp[dec_clock_def] >> strip_tac >> + dxrule s_rel_clock >> simp[dec_clock_def] >> strip_tac >> last_x_assum dxrule >> simp[] >> qmatch_goalsub_abbrev_tac ‘evaluate _ new_env’ >> disch_then $ qspec_then ‘new_env’ mp_tac >> impl_tac @@ -1772,6 +1789,13 @@ Proof DECIDE_TAC QED +Triviality less_sub_2_cases: + k <= clock /\ ¬(clock ≤ 1) ==> + (k = clock \/ k = clock - 1 \/ k <= clock - 2n) +Proof + DECIDE_TAC +QED + Theorem evaluate_record_suffix: (! ^s env exps s' res. evaluate s env exps = (s', res) /\ @@ -1841,16 +1865,18 @@ Proof \\ simp [combine_dec_result_def] >>~ [`getOpClass op = Force`] >- ( - gvs [AllCaseEqs(), dec_clock_def] - \\ drule_then (drule_then assume_tac) less_sub_1_cases \\ gvs [] - \\ imp_res_simp_tac evaluate_is_record_forward \\ gvs []) + gvs [AllCaseEqs(), dec_clock_def] >> + imp_res_simp_tac evaluate_is_record_forward >> gvs [] + >- simp[record_forward_refl] + >- simp[DISJ_EQ_IMP, record_forward_refl] >> + drule_then (drule_then assume_tac) less_sub_2_cases >> gvs [] + ) >- ( gvs [AllCaseEqs(), dec_clock_def] \\ imp_res_simp_tac evaluate_is_record_forward \\ gvs [] >- (drule_then irule record_forward_trans \\ gvs []) >- (drule_then irule record_forward_trans \\ gvs []) >- (disj2_tac \\ drule_then irule record_forward_trans \\ gvs [])) - \\ gs[] QED (* Constructs the oracle from an evaluation by using the recorded diff --git a/compiler/backend/proofs/source_to_flatProofScript.sml b/compiler/backend/proofs/source_to_flatProofScript.sml index b5341665df..cfa36966c0 100644 --- a/compiler/backend/proofs/source_to_flatProofScript.sml +++ b/compiler/backend/proofs/source_to_flatProofScript.sml @@ -4221,13 +4221,14 @@ Proof >- ( Cases_on ‘op’ >> gvs[astTheory.getOpClass_def] >> Cases_on ‘t'’ >> gvs[] >> - gvs[AllCaseEqs(), dec_clock_def, PULL_EXISTS] >> rw[] + gvs[AllCaseEqs(), evaluateTheory.dec_clock_def, flatSemTheory.dec_clock_def, + PULL_EXISTS] >> rw[] >- ( gvs[astOp_to_flatOp_def, evaluate_def, compile_exps_reverse, AllCaseEqs()] >> qpat_x_assum `result_rel _ _ _ r_i1` mp_tac >> rw[Once result_rel_cases] >> - gvs[oneline evaluateTheory.dest_thunk_def, AllCaseEqs()] >> + gvs[oneline semanticPrimitivesTheory.dest_thunk_def, AllCaseEqs()] >> rgs[Once v_rel_cases] >> gvs[] >> simp[dest_thunk_def, AllCaseEqs(), PULL_EXISTS] >> gvs[store_lookup_def, s_rel_cases, LIST_REL_EL_EQN] >> @@ -4243,7 +4244,7 @@ Proof AllCaseEqs()] >> qpat_x_assum `result_rel _ _ _ r_i1` mp_tac >> rw[Once result_rel_cases] >> - gvs[oneline evaluateTheory.dest_thunk_def, AllCaseEqs()] >> + gvs[oneline semanticPrimitivesTheory.dest_thunk_def, AllCaseEqs()] >> rgs[Once v_rel_cases] >> gvs[] >> simp[dest_thunk_def, AllCaseEqs(), PULL_EXISTS] >> gvs[store_lookup_def, s_rel_cases, LIST_REL_EL_EQN] >> @@ -4259,7 +4260,7 @@ Proof AllCaseEqs()] >> qpat_x_assum `result_rel _ _ _ r_i1` mp_tac >> rw[Once result_rel_cases] >> - gvs[oneline evaluateTheory.dest_thunk_def, AllCaseEqs()] >> + gvs[oneline semanticPrimitivesTheory.dest_thunk_def, AllCaseEqs()] >> rgs[Once v_rel_cases] >> gvs[] >> simp[dest_thunk_def, AllCaseEqs(), PULL_EXISTS] >> gvs[store_lookup_def, s_rel_cases, LIST_REL_EL_EQN] >> @@ -4269,34 +4270,43 @@ Proof v_rel genv' v v'` by ( first_x_assum drule >> gvs[] >> rw[Once sv_rel_cases]) >> simp[REWRITE_RULE [ADD1] EL, Once result_rel_cases, PULL_EXISTS] >> - last_x_assum mp_tac >> - disch_then $ qspecl_then [ - `genv'`, `<|c := nsEmpty; v := nsSing "f" (Local None "f")|>`, - `<|v := [("f",v')]|>`, `dec_clock s'_i1`, `["f"]`, `t`, `[None]`, `gen`, - `idxs`] mp_tac >> - impl_tac - >- ( - gvs[invariant_def, evaluateTheory.dec_clock_def, dec_clock_def] >> - gvs[s_rel_cases] >> - gvs[env_all_rel_cases] >> rw[] >> - qexistsl [`nsBind "f" v nsEmpty`, `<|c := nsEmpty; v := nsEmpty|>`] >> - rw[evaluateTheory.sing_env_def] - >- (qexists `[("f",v)]` >> rw[]) - >- simp[Once v_rel_cases] - >- ntac 2 (simp[Once v_rel_cases])) >> - rw[] >> gvs[] >> - gvs[evaluateTheory.AppUnit_def, compile_exp_def, astOp_to_flatOp_def, - bind_locals_def, namespaceTheory.nsBindList_def, compile_var_def] >> - simp[AppUnit_def] >> - qpat_x_assum `result_rel _ _ (Rval _) _` mp_tac >> + simp[AppUnit_def, dec_clock_def] >> + ntac 5 $ simp[Once evaluate_def] >> + drule do_opapp >> simp[PULL_EXISTS] >> + disch_then drule >> simp[Once v_rel_cases] >> strip_tac >> gvs[] >> + goal_assum drule >> simp[] + ) + >- ( + gvs[astOp_to_flatOp_def, evaluate_def, compile_exps_reverse, + AllCaseEqs()] >> + qpat_x_assum `result_rel _ _ _ r_i1` mp_tac >> rw[Once result_rel_cases] >> - gvs[oneline evaluateTheory.update_thunk_def, AllCaseEqs()] >> - simp[update_thunk_def] >> + gvs[oneline semanticPrimitivesTheory.dest_thunk_def, AllCaseEqs()] >> + rgs[Once v_rel_cases] >> gvs[] >> + simp[dest_thunk_def, AllCaseEqs(), PULL_EXISTS] >> + gvs[store_lookup_def, s_rel_cases, LIST_REL_EL_EQN] >> + `n + 1 < LENGTH s'_i1.refs` by (Cases_on `s'_i1.refs` >> gvs[]) >> + gvs[] >> + `∃v'. EL n (TL s'_i1.refs) = Thunk NotEvaluated v' ∧ + v_rel genv' v v'` by ( + first_x_assum drule >> gvs[] >> rw[Once sv_rel_cases]) >> + simp[REWRITE_RULE [ADD1] EL, Once result_rel_cases, PULL_EXISTS] >> + simp[AppUnit_def, dec_clock_def] >> + ntac 5 $ simp[Once evaluate_def] >> + drule do_opapp >> simp[PULL_EXISTS] >> + disch_then drule >> simp[Once v_rel_cases] >> strip_tac >> gvs[] >> + dxrule invariant_dec_clock >> strip_tac >> + dxrule invariant_dec_clock >> strip_tac >> + gvs[evaluateTheory.dec_clock_def, flatSemTheory.dec_clock_def] >> + last_x_assum drule_all >> disch_then $ qspec_then ‘t1’ assume_tac >> gvs[] >> + gvs[Once result_rel_cases] >> + gvs[oneline semanticPrimitivesTheory.update_thunk_def, + oneline flatSemTheory.update_thunk_def, AllCaseEqs()] >> `dest_thunk [y] s'_i1'.refs = NotThunk` by ( qpat_x_assum `v_rel _ v'3' y` mp_tac >> Cases_on `v'3'` >> Cases_on `y` >> rw[Once v_rel_cases, dest_thunk_def, Boolv_def] >> - gvs[evaluateTheory.dest_thunk_def, store_lookup_def] >> + gvs[semanticPrimitivesTheory.dest_thunk_def, store_lookup_def] >> reverse $ rw [] >- (Cases_on `s'_i1'.refs` >> gvs []) >> `n' < LENGTH (TL s'_i1'.refs)` by (Cases_on `s'_i1'.refs` >> gvs[]) >> @@ -4327,13 +4337,14 @@ Proof rw[EL_LUPDATE] >> simp[Once sv_rel_cases]) >- ( gvs[evaluateTheory.dec_clock_def] >> - drule_then irule orac_forward_rel_trans >> gvs[])) + drule_then irule orac_forward_rel_trans >> gvs[]) + ) >- ( gvs[astOp_to_flatOp_def, evaluate_def, compile_exps_reverse, AllCaseEqs()] >> qpat_x_assum `result_rel _ _ _ r_i1` mp_tac >> rw[Once result_rel_cases] >> - gvs[oneline evaluateTheory.dest_thunk_def, AllCaseEqs()] >> + gvs[oneline semanticPrimitivesTheory.dest_thunk_def, AllCaseEqs()] >> rgs[Once v_rel_cases] >> gvs[] >> simp[dest_thunk_def, AllCaseEqs(), PULL_EXISTS] >> gvs[store_lookup_def, s_rel_cases, LIST_REL_EL_EQN] >> @@ -4343,34 +4354,21 @@ Proof v_rel genv' v v'` by ( first_x_assum drule >> gvs[] >> rw[Once sv_rel_cases]) >> simp[REWRITE_RULE [ADD1] EL, Once result_rel_cases, PULL_EXISTS] >> - last_x_assum mp_tac >> - disch_then $ qspecl_then [ - `genv'`, `<|c := nsEmpty; v := nsSing "f" (Local None "f")|>`, - `<|v := [("f",v')]|>`, `dec_clock s'_i1`, `["f"]`, `t`, `[None]`, `gen`, - `idxs`] mp_tac >> - impl_tac - >- ( - gvs[invariant_def, evaluateTheory.dec_clock_def, dec_clock_def] >> - gvs[s_rel_cases] >> - gvs[env_all_rel_cases] >> rw[] >> - qexistsl [`nsBind "f" v nsEmpty`, `<|c := nsEmpty; v := nsEmpty|>`] >> - rw[evaluateTheory.sing_env_def] - >- (qexists `[("f",v)]` >> rw[]) - >- simp[Once v_rel_cases] - >- ntac 2 (simp[Once v_rel_cases])) >> - rw[] >> gvs[] >> - gvs[evaluateTheory.AppUnit_def, compile_exp_def, astOp_to_flatOp_def, - bind_locals_def, namespaceTheory.nsBindList_def, compile_var_def] >> - simp[AppUnit_def] >> - qpat_x_assum `result_rel _ _ (Rerr _) _` mp_tac >> - rw[Once result_rel_cases] - >- ( - qexists `genv'3'` >> gvs[] >> - imp_res_tac SUBMAP_TRANS >> gvs[] >> - imp_res_tac subglobals_trans >> gvs[] >> - gvs[evaluateTheory.dec_clock_def] >> - imp_res_tac orac_forward_rel_trans) - >- metis_tac[])) >> + simp[AppUnit_def, dec_clock_def] >> + ntac 5 $ simp[Once evaluate_def] >> + drule do_opapp >> simp[PULL_EXISTS] >> + disch_then drule >> simp[Once v_rel_cases] >> strip_tac >> gvs[] >> + dxrule invariant_dec_clock >> strip_tac >> + dxrule invariant_dec_clock >> strip_tac >> + gvs[evaluateTheory.dec_clock_def, flatSemTheory.dec_clock_def] >> + last_x_assum drule_all >> disch_then $ qspec_then ‘t1’ assume_tac >> gvs[] >> + qpat_x_assum `result_rel _ _ _ r_i1` mp_tac >> rw[Once result_rel_cases] >> + goal_assum drule >> simp[] >> + imp_res_tac SUBMAP_TRANS >> gvs[] >> + imp_res_tac subglobals_trans >> gvs[] >> + drule_then irule orac_forward_rel_trans >> gvs[] + ) + ) >> fs [Q.ISPEC `(a, b)` EQ_SYM_EQ, option_case_eq, pair_case_eq] >> rw [] >> rveq >> fs [] >> diff --git a/semantics/evaluateScript.sml b/semantics/evaluateScript.sml index 0c8eb5a00f..7a0a587e56 100644 --- a/semantics/evaluateScript.sml +++ b/semantics/evaluateScript.sml @@ -114,16 +114,17 @@ Definition evaluate_def[nocompute]: | NotThunk => (st', Rerr (Rabort Rtype_error)) | IsThunk Evaluated v => (st', Rval [v]) | IsThunk NotEvaluated f => + if st'.clock = 0 then (st', Rerr (Rabort Rtimeout_error)) else case do_opapp [f; Conv NONE []] of | SOME (env',e) => - if st'.clock = 0 then (st', Rerr (Rabort Rtimeout_error)) else - (case evaluate (dec_clock st') env' [e] of + if (dec_clock st').clock = 0 then (dec_clock st', Rerr (Rabort Rtimeout_error)) else + (case evaluate (dec_clock (dec_clock st')) env' [e] of | (st2, Rval vs2) => (case update_thunk (REVERSE vs) st2.refs vs2 of | NONE => (st2, Rerr (Rabort Rtype_error)) | SOME refs => (st2 with refs := refs, Rval vs2)) | (st2, Rerr e) => (st2, Rerr e)) - | NONE => (st', Rerr (Rabort Rtype_error))) + | NONE => (dec_clock st', Rerr (Rabort Rtype_error))) | EvalOp => (case fix_clock st' (do_eval_res (REVERSE vs) st') of (st1, Rval (env1, decs)) => diff --git a/semantics/proofs/evaluatePropsScript.sml b/semantics/proofs/evaluatePropsScript.sml index 50ef56067b..8df6b06691 100644 --- a/semantics/proofs/evaluatePropsScript.sml +++ b/semantics/proofs/evaluatePropsScript.sml @@ -1414,7 +1414,8 @@ Theorem evaluate_Force_alt: | NotThunk => (st', Rerr (Rabort Rtype_error)) | IsThunk Evaluated v => (st', Rval [v]) | IsThunk NotEvaluated f => ( - case evaluate st' (sing_env "f" f) [App Opapp [Var (Short "f"); Con NONE []]] of + if st'.clock = 0 then (st', Rerr (Rabort Rtimeout_error)) else + case evaluate (dec_clock st') (sing_env "f" f) [App Opapp [Var (Short "f"); Con NONE []]] of | (st2, Rval vs2) => ( case update_thunk (REVERSE vs) st2.refs vs2 of | NONE => (st2, Rerr (Rabort Rtype_error)) From 3623588069b6a507e05775bd80ab523a6c314f76 Mon Sep 17 00:00:00 2001 From: Hrutvik Kanabar Date: Sun, 7 Sep 2025 16:20:06 +0100 Subject: [PATCH 086/112] Fix `alt_semantics` --- semantics/alt_semantics/bigStepScript.sml | 29 +++++--- .../alt_semantics/proofs/bigClockScript.sml | 43 ++++++++---- .../proofs/bigSmallEquivScript.sml | 69 ++++++++++++++++--- .../proofs/bigSmallInvariantsScript.sml | 30 ++++---- .../alt_semantics/proofs/interpScript.sml | 31 +++++---- 5 files changed, 145 insertions(+), 57 deletions(-) diff --git a/semantics/alt_semantics/bigStepScript.sml b/semantics/alt_semantics/bigStepScript.sml index c7280d46cc..3e8d11f9c1 100644 --- a/semantics/alt_semantics/bigStepScript.sml +++ b/semantics/alt_semantics/bigStepScript.sml @@ -178,8 +178,19 @@ evaluate ck env s1 (App op es) (( s2 with<| refs := refs'; ffi :=ffi' |>), res)) evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) ∧ opClass op Force ∧ dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧ + ck ∧ s2.clock = 0 + ⇒ evaluate ck env s1 (App op es) (s2, Rerr (Rabort Rtimeout_error))) + +∧ + +(∀ck env op es vs s1 s2 f. + evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) ∧ + opClass op Force ∧ + dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧ + (ck ⇒ s2.clock ≠ 0) ∧ do_opapp [f; Conv NONE []] = NONE - ⇒ evaluate ck env s1 (App op es) (s2, Rerr (Rabort Rtype_error))) + ⇒ evaluate ck env s1 (App op es) + (if ck then s2 with clock := s2.clock - 1 else s2, Rerr (Rabort Rtype_error))) ∧ @@ -196,8 +207,8 @@ evaluate ck env s1 (App op es) (( s2 with<| refs := refs'; ffi :=ffi' |>), res)) opClass op Force ∧ dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧ do_opapp [f; Conv NONE []] = SOME env_e ∧ - ck ∧ s2.clock = 0 - ⇒ evaluate ck env s1 (App op es) (s2, Rerr (Rabort Rtimeout_error))) + ck ∧ s2.clock = 1 + ⇒ evaluate ck env s1 (App op es) (s2 with clock := 0, Rerr (Rabort Rtimeout_error))) ∧ @@ -206,8 +217,8 @@ evaluate ck env s1 (App op es) (( s2 with<| refs := refs'; ffi :=ffi' |>), res)) opClass op Force ∧ dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧ do_opapp [f; Conv NONE []] = SOME (env', e) ∧ - (ck ⇒ s2.clock ≠ 0) ∧ - evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rerr err) + (ck ⇒ ¬(s2.clock ≤ 1)) ∧ + evaluate ck env' (if ck then (s2 with clock := s2.clock - 2) else s2) e (s3, Rerr err) ⇒ evaluate ck env s1 (App op es) (s3, Rerr err)) ∧ @@ -217,8 +228,8 @@ evaluate ck env s1 (App op es) (( s2 with<| refs := refs'; ffi :=ffi' |>), res)) opClass op Force ∧ dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧ do_opapp [f; Conv NONE []] = SOME (env', e) ∧ - (ck ⇒ s2.clock ≠ 0) ∧ - evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rval vs2) ∧ + (ck ⇒ ¬(s2.clock ≤ 1)) ∧ + evaluate ck env' (if ck then (s2 with clock := s2.clock - 2) else s2) e (s3, Rval vs2) ∧ update_thunk (REVERSE vs) s3.refs [vs2] = NONE ⇒ evaluate ck env s1 (App op es) (s3, Rerr (Rabort Rtype_error))) @@ -229,8 +240,8 @@ evaluate ck env s1 (App op es) (( s2 with<| refs := refs'; ffi :=ffi' |>), res)) opClass op Force ∧ dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧ do_opapp [f; Conv NONE []] = SOME (env', e) ∧ - (ck ⇒ s2.clock ≠ 0) ∧ - evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rval vs2) ∧ + (ck ⇒ ¬(s2.clock ≤ 1)) ∧ + evaluate ck env' (if ck then (s2 with clock := s2.clock - 2) else s2) e (s3, Rval vs2) ∧ update_thunk (REVERSE vs) s3.refs [vs2] = SOME refs ⇒ evaluate ck env s1 (App op es) (s3 with refs := refs, Rval vs2)) diff --git a/semantics/alt_semantics/proofs/bigClockScript.sml b/semantics/alt_semantics/proofs/bigClockScript.sml index 3528eec97d..6d042ef8b9 100644 --- a/semantics/alt_semantics/proofs/bigClockScript.sml +++ b/semantics/alt_semantics/proofs/bigClockScript.sml @@ -131,6 +131,7 @@ Proof >- metis_tac[] >- metis_tac[] >- metis_tac[] + >- metis_tac[] >- ( ntac 3 disj2_tac >> disj1_tac >> last_x_assum $ irule_at Any >> simp[] @@ -300,21 +301,26 @@ Proof first_assum(match_exists_tac o concl) >> simp[] >> NO_TAC) >>~ [‘ThunkOp ForceThunk’] >- ( - gvs[] >> ntac 4 disj2_tac >> disj1_tac >> + gvs[] >> ntac 2 disj2_tac >> disj1_tac >> dxrule $ cj 2 add_to_counter >> simp[] >> - disch_then $ qspec_then ‘c' + 1’ assume_tac >> - goal_assum drule >> simp[] + disch_then $ qspec_then ‘1’ $ irule_at Any >> simp[] + ) + >- ( + gvs[] >> ntac 5 disj2_tac >> disj1_tac >> + dxrule $ cj 2 add_to_counter >> simp[] >> + disch_then $ qspec_then ‘c' + 2’ $ irule_at Any >> simp[] >> + goal_assum drule ) >- ( gvs[] >> ntac 4 disj2_tac >> disj1_tac >> dxrule $ cj 2 add_to_counter >> simp[] >> - disch_then $ qspec_then ‘c' + 1’ assume_tac >> + disch_then $ qspec_then ‘c' + 2’ assume_tac >> rpt (goal_assum drule >> simp[]) ) >- ( gvs[] >> disj2_tac >> dxrule $ cj 2 add_to_counter >> simp[] >> - disch_then $ qspec_then ‘c' + 1’ assume_tac >> + disch_then $ qspec_then ‘c' + 2’ assume_tac >> goal_assum $ drule_at Any >> simp[] >> goal_assum $ drule_at $ Pat ‘evaluate _ _ _ _ _’ >> simp[] ) >> @@ -596,18 +602,21 @@ Proof ntac 2 disj2_tac >> Cases_on ‘t’ >> gvs[] >- metis_tac[] >> rename1 ‘IsThunk _ f’ >> + Cases_on ‘s2.clock = 0’ >- metis_tac[] >> Cases_on ‘do_opapp [f; Conv NONE []]’ >- metis_tac[] >> + Cases_on ‘s2.clock = 1’ >- metis_tac[] >> + ‘¬(s2.clock ≤ 1)’ by gvs[] >> gvs[] >> rename1 ‘SOME env_e’ >> PairCases_on ‘env_e’ >> - ntac 2 disj2_tac >> - Cases_on ‘s2.clock = 0’ >- metis_tac[] >> - disj2_tac >> - last_x_assum $ qspec_then ‘s2.clock - 1’ mp_tac >> + ntac 4 disj2_tac >> + last_x_assum $ qspec_then ‘s2.clock - 2’ mp_tac >> last_x_assum kall_tac >> impl_tac >- (imp_res_tac clock_monotone >> gvs[]) >> disch_then $ qspecl_then [‘env_e1’,‘env_e0’,‘s2’] $ qx_choosel_then [‘s3’,‘res’] assume_tac >> - reverse $ Cases_on ‘res’ >- metis_tac[] >> - disj2_tac >> Cases_on ‘update_thunk (REVERSE v) s3.refs [a]’ >> metis_tac[]) >> + reverse $ Cases_on ‘res’ + >- metis_tac[] >> + disj2_tac >> Cases_on ‘update_thunk (REVERSE v) s3.refs [a]’ >> metis_tac[] + ) >> `(do_app (s2.refs,s2.ffi) o' (REVERSE v) = NONE) ∨ (?s3 e2. do_app (s2.refs,s2.ffi) o' (REVERSE v) = SOME (s3,e2))` by metis_tac [optionTheory.option_nchotomy, pair_CASES] @@ -797,10 +806,18 @@ Proof >- simp[SF SFY_ss] >- simp[SF SFY_ss] >- simp[SF SFY_ss] + >- ( + ntac 5 disj2_tac >> disj1_tac >> + last_x_assum $ irule_at Any >> simp[] >> + qexists ‘count'' + 1’ >> simp[] + ) >- simp[SF SFY_ss] - >- simp[SF SFY_ss] >- ( - ntac 8 disj2_tac >> disj1_tac >> + ntac 4 disj2_tac >> disj1_tac >> + last_x_assum $ irule_at Any >> simp[] + ) + >- ( + ntac 9 disj2_tac >> disj1_tac >> last_x_assum $ irule_at Any >> simp[] >> first_x_assum $ irule_at Any >> simp[] >> qexists ‘s2.clock - extra’ >> simp[] >> diff --git a/semantics/alt_semantics/proofs/bigSmallEquivScript.sml b/semantics/alt_semantics/proofs/bigSmallEquivScript.sml index eb9cd5ce0f..f568212f55 100644 --- a/semantics/alt_semantics/proofs/bigSmallEquivScript.sml +++ b/semantics/alt_semantics/proofs/bigSmallEquivScript.sml @@ -872,14 +872,26 @@ Proof >- ( disj2_tac >> disj1_tac >> simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss] ) + >- simp[SF SFY_ss] + >- ( + ntac 2 disj2_tac >> disj1_tac >> + simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss] >> + irule_at Any EQ_REFL >> simp[SF SFY_ss] + ) >- ( ntac 2 disj2_tac >> disj1_tac >> simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss] ) - >- simp[SF SFY_ss] - >- simp[SF SFY_ss] >- ( - ntac 4 disj2_tac >> disj1_tac >> + disj1_tac >> rpt $ goal_assum $ drule_at Any >> + qspec_then ‘s2'’ assume_tac $ GEN_ALL with_same_clock >> gvs[] + ) + >- ( + disj2_tac >> disj1_tac >> irule_at Any EQ_REFL >> + simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss] + ) + >- ( + ntac 5 disj2_tac >> disj1_tac >> simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss] ) >- ( @@ -965,13 +977,37 @@ Proof by gvs[getOpClass_opClass, opClass_cases] >> simp[SF DNF_ss, GSYM DISJ_ASSOC] >> gvs[AllCaseEqs()] >- ( - ntac 3 disj2_tac >> disj1_tac >> simp[Once evaluate_cases, SF SFY_ss] + ntac 2 disj2_tac >> disj1_tac >> simp[Once evaluate_cases, SF SFY_ss] ) >> once_rewrite_tac[cj 2 evaluate_cases] >> simp[] >> gvs[evaluate_ctxts_cons] >> gvs[evaluate_ctxt_cases, update_thunk_def, AllCaseEqs(), SF SFY_ss] >> - gvs[Once $ cj 2 evaluate_cases] >> - gvs[opClass_cases] >> metis_tac[] + gvs[Once $ cj 2 evaluate_cases, opClass_cases] >> + (reverse $ Cases_on ‘ck’ >> gvs[] >- metis_tac[]) + >- ( + ntac 3 disj2_tac >> disj1_tac >> + qexists ‘clk + 1’ >> simp[] >> goal_assum drule >> simp[] + ) + >- ( + ntac 3 disj2_tac >> disj1_tac >> + qexists ‘clk + 1’ >> simp[] >> goal_assum drule >> simp[] + ) + >- ( + ntac 3 disj2_tac >> disj1_tac >> + qexists ‘clk + 1’ >> simp[] >> goal_assum drule >> simp[] + ) + >- ( + rpt disj2_tac >> + qexists ‘clk + 1’ >> simp[] >> goal_assum drule >> simp[] + ) + >- ( + ntac 2 disj2_tac >> disj1_tac >> + qexists ‘clk + 1’ >> simp[] >> goal_assum drule >> simp[] + ) + >- ( + disj1_tac >> + qexists ‘clk + 1’ >> simp[] >> goal_assum drule >> simp[] + ) ) >> once_rewrite_tac[cj 2 evaluate_cases] >> simp[] >> every_case_tac >> gvs[SF DNF_ss, SF SFY_ss] >> @@ -1783,7 +1819,20 @@ Proof >- ( (* App - do_app timeout *) drule do_app_not_timeout >> simp[] ) - >- ( (* Force - timeout *) + >- ( (* Force - timeout 1 *) + dxrule big_clocked_to_unclocked_list >> rw[] >> + dxrule $ cj 2 big_exp_to_small_exp >> rw[] >> + gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_res_def] >> + imp_res_tac small_eval_list_length >> gvs[LENGTH_EQ_NUM_compute] >> + ntac 2 $ gvs[Once small_eval_list_cases] >> + irule_at Any $ cj 2 RTC_rules >> + simp[e_step_reln_def, e_step_def, push_def, application_thm] >> + irule_at Any $ cj 2 RTC_RULES_RIGHT1 >> + dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> + simp[e_step_reln_def, e_step_def, continue_def, application_thm, getOpClass_def] >> + gvs[dest_thunk_def, to_small_st_def] + ) + >- ( (* Force - timeout 2 *) dxrule big_clocked_to_unclocked_list >> rw[] >> dxrule $ cj 2 big_exp_to_small_exp >> rw[] >> gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_res_def] >> @@ -2251,10 +2300,12 @@ Proof rename1 ‘evaluate_list _ _ _ _ (s2,Rval vs2)’ >> Cases_on ‘dest_thunk (REVERSE vs2 ++ [v] ++ l) s2.refs’ >> gvs[SF SFY_ss] >> rename1 ‘IsThunk t f’ >> Cases_on ‘t’ >> gvs[SF SFY_ss] >> + Cases_on ‘s2.clock = 0’ >> gvs[SF SFY_ss] >> Cases_on ‘do_opapp [f; Conv NONE []]’ >> gvs[SF SFY_ss] >> rename1 ‘SOME env_e’ >> PairCases_on ‘env_e’ >> - Cases_on ‘s2.clock = 0’ >> gvs[SF SFY_ss] >> - qspecl_then [‘s2 with clock := s2.clock - 1’,‘env_e0’,‘env_e1’] + Cases_on ‘s2.clock = 1’ >> gvs[SF SFY_ss] >> + ‘¬ (s2.clock ≤ 1)’ by gvs[] >> gvs[] >> + qspecl_then [‘s2 with clock := s2.clock - 2’,‘env_e0’,‘env_e1’] assume_tac big_clocked_total >> gvs[] >> rename1 ‘evaluate _ _ _ _ (s3, res)’ >> Cases_on ‘res’ >> gvs[SF SFY_ss] >> rename1 ‘Rval v'’ >> diff --git a/semantics/alt_semantics/proofs/bigSmallInvariantsScript.sml b/semantics/alt_semantics/proofs/bigSmallInvariantsScript.sml index 06902a4028..f4b1773c28 100644 --- a/semantics/alt_semantics/proofs/bigSmallInvariantsScript.sml +++ b/semantics/alt_semantics/proofs/bigSmallInvariantsScript.sml @@ -45,9 +45,7 @@ Inductive evaluate_ctxt: (opClass op Force ∧ evaluate_list ck env s1 es (s2, Rval vs2) ∧ (dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = BadRef ∨ - dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = NotThunk ∨ - (dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧ - do_opapp [f; Conv NONE []] = NONE)) + dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = NotThunk) ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v (s2, Rerr (Rabort Rtype_error))) ∧ @@ -56,20 +54,28 @@ Inductive evaluate_ctxt: dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk Evaluated v' ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v (s2, Rval v')) ∧ + (opClass op Force ∧ + evaluate_list ck env s1 es (s2, Rval vs2) ∧ + dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧ + (ck ⇒ s2.clock ≠ 0) ∧ + do_opapp [f; Conv NONE []] = NONE + ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v + (if ck then s2 with clock := s2.clock - 1 else s2, Rerr (Rabort Rtype_error))) ∧ + (opClass op Force ∧ evaluate_list T env s1 es (s2, Rval vs2) ∧ dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧ - do_opapp [f; Conv NONE []] = SOME env_e ∧ - s2.clock = 0 + (s2.clock = 0 ∨ + (s2.clock = 1 ∧ do_opapp [f; Conv NONE []] = SOME env_e)) ⇒ evaluate_ctxt T env s1 (Capp op vs1 () es) v - (s2, Rerr (Rabort Rtimeout_error))) ∧ + (s2 with clock := 0, Rerr (Rabort Rtimeout_error))) ∧ (opClass op Force ∧ evaluate_list ck env s1 es (s2, Rval vs2) ∧ dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧ do_opapp [f; Conv NONE []] = SOME (env', e) ∧ - (ck ⇒ s2.clock ≠ 0) ∧ - evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rerr err) + (ck ⇒ ¬(s2.clock ≤ 1)) ∧ + evaluate ck env' (if ck then (s2 with clock := s2.clock - 2) else s2) e (s3, Rerr err) ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v (s3, Rerr err)) ∧ @@ -77,8 +83,8 @@ Inductive evaluate_ctxt: evaluate_list ck env s1 es (s2, Rval vs2) ∧ dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧ do_opapp [f; Conv NONE []] = SOME (env', e) ∧ - (ck ⇒ s2.clock ≠ 0) ∧ - evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rval v') ∧ + (ck ⇒ ¬(s2.clock ≤ 1)) ∧ + evaluate ck env' (if ck then (s2 with clock := s2.clock - 2) else s2) e (s3, Rval v') ∧ update_thunk (REVERSE vs2 ++ [v] ++ vs1) s3.refs [v'] = NONE ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v (s3, Rerr (Rabort Rtype_error))) ∧ @@ -87,8 +93,8 @@ Inductive evaluate_ctxt: evaluate_list ck env s1 es (s2, Rval vs2) ∧ dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧ do_opapp [f; Conv NONE []] = SOME (env', e) ∧ - (ck ⇒ s2.clock ≠ 0) ∧ - evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rval v') ∧ + (ck ⇒ ¬(s2.clock ≤ 1)) ∧ + evaluate ck env' (if ck then (s2 with clock := s2.clock - 2) else s2) e (s3, Rval v') ∧ update_thunk (REVERSE vs2 ++ [v] ++ vs1) s3.refs [v'] = SOME refs ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v (s3 with refs := refs, Rval v')) ∧ diff --git a/semantics/alt_semantics/proofs/interpScript.sml b/semantics/alt_semantics/proofs/interpScript.sml index 7ac6317659..85d03f6ca4 100644 --- a/semantics/alt_semantics/proofs/interpScript.sml +++ b/semantics/alt_semantics/proofs/interpScript.sml @@ -213,19 +213,22 @@ Theorem run_eval_def: | NotThunk => raise (Rabort Rtype_error) | IsThunk Evaluated v => return v | IsThunk NotEvaluated f => - case do_opapp [f; Conv NONE []] of - | SOME (env',e) => do - () <- dec_clock; - v2 <- run_eval env' e; - ^st <- get_store; - (case update_thunk (REVERSE vs) st.refs [v2] of - | NONE => raise (Rabort Rtype_error) - | SOME refs => do - () <- set_store (st with refs := refs); - return v2; - od) - od - | NONE => raise (Rabort Rtype_error)) + do + () <- dec_clock; + case do_opapp [f; Conv NONE []] of + | SOME (env',e) => do + () <- dec_clock; + v2 <- run_eval env' e; + ^st <- get_store; + (case update_thunk (REVERSE vs) st.refs [v2] of + | NONE => raise (Rabort Rtype_error) + | SOME refs => do + () <- set_store (st with refs := refs); + return v2; + od) + od + | NONE => raise (Rabort Rtype_error) + od) | Simple => (case do_app (st.refs,st.ffi) op (REVERSE vs) of | NONE => raise (Rabort Rtype_error) @@ -344,7 +347,7 @@ Proof ‘¬opClass op FunApp ∧ ¬opClass op Simple’ by (Cases_on ‘op’ >> gvs[opClass_cases]) >> simp[] >> every_case_tac >> gvs[GSYM evaluate_run_eval_list, GSYM evaluate_run_eval] >> - metis_tac[] + gvs[LESS_OR_EQ] >> metis_tac[] ) >> Cases_on ‘getOpClass op = Simple’ >> gs[] >- (‘~ opClass op FunApp ∧ ¬opClass op Force’ by From ccc071a9aeab12ce05117656b915f28de1b999b4 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Tue, 16 Sep 2025 22:11:37 +0200 Subject: [PATCH 087/112] Prove bittests correct --- .../proofs/data_to_wordProofScript.sml | 60 ++++++++++++++++--- 1 file changed, 52 insertions(+), 8 deletions(-) diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml index 02f19ffade..957a9fb64b 100644 --- a/compiler/backend/proofs/data_to_wordProofScript.sml +++ b/compiler/backend/proofs/data_to_wordProofScript.sml @@ -50,6 +50,52 @@ Proof \\ gvs[do_space_def,AllCaseEqs(),consume_space_def] QED +Triviality word_test_lemma1: + good_dimindex (:α) ⇒ + (0b111100w && x = n2w ((8 + 6) * 4):'a word ⇔ + ~ word_bit 2 x ∧ word_bit 3 x ∧ word_bit 4 x ∧ word_bit 5 x) +Proof + simp [word_eq,word_bit_and,word_bit_n2w,good_dimindex_def] + \\ rw [] \\ gvs [] \\ rw [] + \\ simp [METIS_PROVE [] “(∀n. (P n = Q n)) ⇔ (∀n. P n ⇒ Q n) ∧ (∀n. Q n ⇒ P n)”] + \\ gvs [SF DNF_ss,SF CONJ_ss] +QED + +Triviality word_test_lemma2: + good_dimindex (:α) ⇒ + (0b111100w && x = n2w ((0 + 6) * 4):'a word ⇔ + ~ word_bit 2 x ∧ word_bit 3 x ∧ word_bit 4 x ∧ ~ word_bit 5 x) +Proof + simp [word_eq,word_bit_and,word_bit_n2w,good_dimindex_def] + \\ rw [] \\ gvs [] \\ rw [] + \\ simp [METIS_PROVE [] “(∀n. (P n = Q n)) ⇔ (∀n. P n ⇒ Q n) ∧ (∀n. Q n ⇒ P n)”] + \\ gvs [SF DNF_ss,SF CONJ_ss] + \\ eq_tac \\ rw [] \\ gvs [] + \\ first_assum $ qspec_then ‘2’ assume_tac + \\ first_assum $ qspec_then ‘3’ assume_tac + \\ first_assum $ qspec_then ‘4’ assume_tac + \\ first_assum $ qspec_then ‘5’ assume_tac + \\ fs [] +QED + +Theorem memory_rel_Thunk_bits: + memory_rel c be ts refs sp st m dm ((RefPtr bl p,Word (w:'a word))::vars) ∧ + lookup p refs = SOME (Thunk ev z) ∧ good_dimindex (:α) ∧ + get_real_addr c st w = SOME a ∧ + m a = Word x + ⇒ + (case ev of + | Evaluated => 0b111100w && x = n2w ((8 + 6) * 4) + | NotEvaluated => 0b111100w && x = n2w ((0 + 6) * 4)) +Proof + strip_tac + \\ drule_all memory_rel_Thunk_IMP \\ fs [] + \\ strip_tac + \\ drule word_test_lemma1 \\ fs [] + \\ drule word_test_lemma2 \\ fs [] + \\ Cases_on ‘ev’ \\ gs [] +QED + Theorem memory_rel_Force: memory_rel c be ts refs sp st m dm ((RefPtr bl nn,ptr)::vars) /\ lookup nn refs = SOME (Thunk ev v) /\ @@ -59,9 +105,6 @@ Theorem memory_rel_Force: get_real_addr c st ptr_w = SOME x /\ x IN dm /\ m x = Word w /\ (x + bytes_in_word) IN dm /\ - (case ev of - | Evaluated => 0b111100w && w = n2w ((8 + 6) * 4) - | NotEvaluated => 0b111100w && w = n2w ((0 + 6) * 4)) (* cheated *) /\ memory_rel c be ts refs sp st m dm ((v,m (x + bytes_in_word))::(RefPtr bl nn,ptr)::vars) Proof @@ -85,10 +128,11 @@ Proof \\ imp_res_tac heap_lookup_SPLIT \\ PairCases_on `b` \\ fs [] \\ fs [word_heap_APPEND,word_heap_def,word_el_def,word_payload_def] + \\ pairarg_tac \\ gvs [] + \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR] \\ gvs [] \\ Cases_on `b0` \\ fs [word_payload_def] - \\ fs [word_list_def,word_list_APPEND,SEP_CLAUSES] \\ fs [SEP_F_def] + \\ gvs [word_list_def,word_list_APPEND,SEP_CLAUSES] \\ fs [SEP_F_def] \\ SEP_R_TAC \\ fs [] - \\ cheat QED Theorem state_rel_call_env_get_var: @@ -203,8 +247,8 @@ Proof \\ Cases_on `names_opt` \\ fs [cut_state_opt_def] \\ srw_tac[][] \\ fs [] \\ fs [cut_state_def,cut_env_def] \\ every_case_tac \\ fs [] \\ rw [] \\ fs [set_var_def]) - >~ [‘evaluate (Force _ _ _,s)’] >- ( - gvs [evaluate_def] + >~ [‘evaluate (Force _ _ _,s)’] >- + (gvs [evaluate_def] \\ Cases_on `get_var src s.locals` \\ gvs [] \\ Cases_on `dest_thunk x s.refs` \\ gvs [] \\ simp [comp_def, force_thunk_def] @@ -230,6 +274,7 @@ Proof \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ drule_all memory_rel_get_var_IMP \\ rw [] \\ gvs [] \\ drule_all memory_rel_Force \\ rw [] \\ gvs [] + \\ drule_all memory_rel_Thunk_bits \\ strip_tac \\ `word_exp t (real_addr c (adjust_var src)) = SOME (Word x)` by metis_tac [get_real_addr_lemma] \\ gvs [] \\ simp [wordSemTheory.set_var_def, wordSemTheory.word_exp_def, @@ -2347,4 +2392,3 @@ Proof simp[EVERY_MAP,LAMBDA_PROD,compile_part_def,data_to_word_comp_good_handlers]>> fs[EVERY_MEM,FORALL_PROD] QED - From 066a7917b6bb3459986312b5dcb109c7de99bd81 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Wed, 17 Sep 2025 13:04:25 +0200 Subject: [PATCH 088/112] Fix for new constant sign from HOL --- compiler/backend/proofs/data_to_word_memoryProofScript.sml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/compiler/backend/proofs/data_to_word_memoryProofScript.sml b/compiler/backend/proofs/data_to_word_memoryProofScript.sml index dcf2547526..b2c62c6dcc 100644 --- a/compiler/backend/proofs/data_to_word_memoryProofScript.sml +++ b/compiler/backend/proofs/data_to_word_memoryProofScript.sml @@ -26,6 +26,7 @@ fun rpt_drule th = drule (th |> GEN_ALL) \\ rpt (disch_then drule \\ fs []) val _ = augment_srw_ss[rewrites[LENGTH_REPLICATE]] val _ = Parse.hide"el"; +val _ = Parse.hide"sign"; Overload good_dimindex[local] = ``misc$good_dimindex`` val LESS_4 = DECIDE ``i < 4 <=> (i = 0) \/ (i = 1) \/ (i = 2) \/ (i = 3n)`` @@ -5723,9 +5724,9 @@ Theorem memory_rel_WordOp64_alt = Triviality IMP_memory_rel_bignum_alt: memory_rel c be ts refs sp st m dm (vs ++ vars) ∧ good_dimindex (:α) ∧ ¬small_int (:α) i ∧ - (Bignum i :α ml_el) = DataElement [] (LENGTH ws) (NumTag sign,MAP Word ws) ∧ + (Bignum i :α ml_el) = DataElement [] (LENGTH ws) (NumTag is_neg,MAP Word ws) ∧ LENGTH ws < sp ∧ - encode_header c (w2n ((b2w sign <<2 || 3w):α word)) (LENGTH ws) = + encode_header c (w2n ((b2w is_neg <<2 || 3w):α word)) (LENGTH ws) = SOME (hd:α word) ⇒ ∃next curr m1. FLOOKUP st NextFree = SOME (Word next) ∧ @@ -14033,4 +14034,3 @@ Proof \\ gvs [SEP_CLAUSES] \\ gvs [AC STAR_COMM STAR_ASSOC]) QED - From a37e850b21678b312399eeb731c170518d8e2802 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Thu, 18 Sep 2025 09:29:13 +0200 Subject: [PATCH 089/112] Fix some broken proofs and update a README --- examples/diffScript.sml | 8 +++----- pancake/static_checker/README.md | 1 + 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/examples/diffScript.sml b/examples/diffScript.sml index 2ceef0b503..84812ea960 100644 --- a/examples/diffScript.sml +++ b/examples/diffScript.sml @@ -469,8 +469,7 @@ Triviality tokens_toString_comma: Proof rw [] \\ match_mp_tac tokens_eq_sing \\ fs [num_to_str_thm,implode_def] - \\ fs [num_to_str_def] - \\ match_mp_tac (MP_CANON EVERY_MONOTONIC) + \\ irule EVERY_MONOTONIC \\ qexists_tac `isDigit` \\ fs [EVERY_isDigit_num_to_dec_string] \\ EVAL_TAC QED @@ -483,11 +482,11 @@ Proof by(fs[line_numbers_def] >> rw[] \\ fs[toString_thm,num_to_str_def] \\ fs[explode_implode,strcat_thm] - \\ match_mp_tac (MP_CANON EVERY_MONOTONIC) + \\ irule EVERY_MONOTONIC \\ qexists_tac `isDigit` \\ fs [toString_isDigit]) \\ match_mp_tac tokens_eq_sing \\ conj_tac THEN1 - (match_mp_tac (MP_CANON EVERY_MONOTONIC) + (irule EVERY_MONOTONIC \\ goal_assum (first_x_assum o mp_then Any mp_tac) \\ fs [] \\ CCONTR_TAC \\ fs [] \\ rveq \\ fs [isDigit_def]) \\ rw [line_numbers_def,num_to_str_thm,implode_def] @@ -1355,4 +1354,3 @@ Proof >> pop_assum $ PURE_ONCE_REWRITE_TAC o single >> fs[] QED - diff --git a/pancake/static_checker/README.md b/pancake/static_checker/README.md index 2b7cb5f4f9..f243d59367 100644 --- a/pancake/static_checker/README.md +++ b/pancake/static_checker/README.md @@ -2,3 +2,4 @@ Support files for Pancake static checker [panStaticExamplesScript.sml](panStaticExamplesScript.sml): * Some simple static checking examples/unit tests/sanity checks for Pancake +* Inspect interactive output manually for more detailed checking From 653745b233a9789fdc74c11e2df10b5b7ba0cff1 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 18 Sep 2025 12:23:38 +0300 Subject: [PATCH 090/112] Fix semantics to remove double clocking in Force --- .../proofs/data_to_wordProofScript.sml | 19 +++- compiler/backend/semantics/bviSemScript.sml | 17 ++-- compiler/backend/semantics/bvlSemScript.sml | 17 ++-- compiler/backend/semantics/closSemScript.sml | 59 +++++++++--- compiler/backend/semantics/dataSemScript.sml | 55 +++++------ compiler/backend/semantics/flatSemScript.sml | 95 ++++++++++++++----- semantics/evaluateScript.sml | 21 ++-- 7 files changed, 187 insertions(+), 96 deletions(-) diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml index 957a9fb64b..7fb199692b 100644 --- a/compiler/backend/proofs/data_to_wordProofScript.sml +++ b/compiler/backend/proofs/data_to_wordProofScript.sml @@ -317,13 +317,28 @@ Proof mp_tac th THEN match_mp_tac memory_rel_rearrange) \\ rw [] \\ gvs [] \\ cheat) - \\ `¬word_cmp Equal 24w 56w` by cheat \\ gvs [] + \\ `¬word_cmp Equal 24w 56w` by ( + simp [asmTheory.word_cmp_def, dimword_def] \\ fs [good_dimindex_def]) + \\ gvs [] \\ simp [asmTheory.word_cmp_def] \\ simp [wordSemTheory.get_vars_def, wordSemTheory.get_var_def, lookup_insert] \\ simp [GSYM wordSemTheory.get_var_def] \\ simp [wordSemTheory.bad_dest_args_def] - \\ Cases_on `s.clock = 0` \\ gvs [] >- cheat + \\ Cases_on `s.clock = 0` \\ gvs [] >- ( + TOP_CASE_TAC \\ simp [wordSemTheory.evaluate_def] + >- ( + simp [wordSemTheory.get_vars_def, wordSemTheory.get_var_def, + lookup_insert] + \\ simp [GSYM wordSemTheory.get_var_def] + \\ simp [wordSemTheory.bad_dest_args_def] + \\ cheat) + \\ TOP_CASE_TAC \\ simp [wordSemTheory.evaluate_def] + \\ simp [wordSemTheory.get_vars_def, wordSemTheory.get_var_def, + lookup_insert] + \\ simp [GSYM wordSemTheory.get_var_def] + \\ simp [wordSemTheory.bad_dest_args_def] + \\ cheat) \\ Cases_on `find_code (SOME loc) [RefPtr v0 ptr; a] s.code s.stack_frame_sizes` \\ gvs [] \\ Cases_on `x''` \\ gvs [] diff --git a/compiler/backend/semantics/bviSemScript.sml b/compiler/backend/semantics/bviSemScript.sml index 49c6cf0efe..9b177cb160 100644 --- a/compiler/backend/semantics/bviSemScript.sml +++ b/compiler/backend/semantics/bviSemScript.sml @@ -241,16 +241,13 @@ Definition evaluate_def: | NotThunk => (Rerr (Rabort Rtype_error),s) | IsThunk Evaluated v => (Rval [v],s) | IsThunk NotEvaluated f => - if s.clock = 0 then - (Rerr (Rabort Rtimeout_error),s) - else - (case find_code (SOME force_loc) [thunk_v; f] s.code of - | NONE => (Rerr(Rabort Rtype_error),s) - | SOME (args,exp) => - if s.clock = 0 then - (Rerr(Rabort Rtimeout_error),s with clock := 0) - else - evaluate ([exp],args,dec_clock 1 s))) /\ + (case find_code (SOME force_loc) [thunk_v; f] s.code of + | NONE => (Rerr(Rabort Rtype_error),s) + | SOME (args,exp) => + if s.clock = 0 then + (Rerr(Rabort Rtimeout_error),s with clock := 0) + else + evaluate ([exp],args,dec_clock 1 s))) /\ (evaluate ([Call ticks dest xs handler],env,s1) = if IS_NONE dest /\ IS_SOME handler then (Rerr(Rabort Rtype_error),s1) else case fix_clock s1 (evaluate (xs,env,s1)) of diff --git a/compiler/backend/semantics/bvlSemScript.sml b/compiler/backend/semantics/bvlSemScript.sml index e661ae16ae..765873b4b7 100644 --- a/compiler/backend/semantics/bvlSemScript.sml +++ b/compiler/backend/semantics/bvlSemScript.sml @@ -585,16 +585,13 @@ Definition evaluate_def: | NotThunk => (Rerr (Rabort Rtype_error),s) | IsThunk Evaluated v => (Rval [v],s) | IsThunk NotEvaluated f => - if s.clock = 0 then - (Rerr (Rabort Rtimeout_error),s) - else - (case find_code (SOME force_loc) [thunk_v; f] s.code of - | NONE => (Rerr(Rabort Rtype_error),s) - | SOME (args,exp) => - if s.clock = 0 then - (Rerr(Rabort Rtimeout_error),s with clock := 0) - else - evaluate ([exp],args,dec_clock 1 s))) /\ + (case find_code (SOME force_loc) [thunk_v; f] s.code of + | NONE => (Rerr(Rabort Rtype_error),s) + | SOME (args,exp) => + if s.clock = 0 then + (Rerr(Rabort Rtimeout_error),s with clock := 0) + else + evaluate ([exp],args,dec_clock 1 s))) /\ (evaluate ([Call ticks dest xs],env,s1) = case fix_clock s1 (evaluate (xs,env,s1)) of | (Rval vs,s) => diff --git a/compiler/backend/semantics/closSemScript.sml b/compiler/backend/semantics/closSemScript.sml index 67bdfc422a..7497f1d497 100644 --- a/compiler/backend/semantics/closSemScript.sml +++ b/compiler/backend/semantics/closSemScript.sml @@ -631,6 +631,45 @@ Definition AppUnit_def: AppUnit x = closLang$App None NONE x [Op None (BlockOp (Cons 0)) []] End +Definition exp_alt_size_def[simp]: + exp_alt_size (Var a0 a1) = 1 + (tra_size a0 + a1) ∧ + exp_alt_size (If a0 a1 a2 a3) = + 1 + (tra_size a0 + (exp_alt_size a1 + (exp_alt_size a2 + exp_alt_size a3))) ∧ + exp_alt_size (Let a0 a1 a2) = + 1 + (tra_size a0 + (exp3_alt_size a1 + exp_alt_size a2)) ∧ + exp_alt_size (Raise a0 a1) = 1 + (tra_size a0 + exp_alt_size a1) ∧ + exp_alt_size (Handle a0 a1 a2) = + 1 + (tra_size a0 + (exp_alt_size a1 + exp_alt_size a2)) ∧ + exp_alt_size (Tick a0 a1) = 1 + (tra_size a0 + exp_alt_size a1) ∧ + exp_alt_size (Call a0 a1 a2 a3) = + 1 + (tra_size a0 + (a1 + (a2 + exp3_alt_size a3))) ∧ + exp_alt_size (App a0 a1 a2 a3) = + 1 + + (tra_size a0 + (option_size (λx. x) a1 + (exp_alt_size a2 + exp3_alt_size a3))) ∧ + exp_alt_size (Fn a0 a1 a2 a3 a4) = + 1 + + (mlstring_size a0 + + (option_size (λx. x) a1 + + (option_size (list_size (λx. x)) a2 + (a3 + exp_alt_size a4)))) ∧ + exp_alt_size (Letrec a0 a1 a2 a3 a4) = + 1 + + (list_size mlstring_size a0 + + (option_size (λx. x) a1 + + (option_size (list_size (λx. x)) a2 + (exp1_alt_size a3 + exp_alt_size a4)))) ∧ + exp_alt_size (Op a0 a1 a2) = 1 + (tra_size a0 + (op_size a1 + exp3_alt_size a2)) + + (if a1 = ThunkOp ForceThunk then 100 else 0) ∧ + exp1_alt_size [] = 0 ∧ + exp1_alt_size (a0::a1) = 1 + (exp2_alt_size a0 + exp1_alt_size a1) ∧ + exp2_alt_size (a0,a1) = 1 + (a0 + exp_alt_size a1) ∧ exp3_alt_size [] = 0 ∧ + exp3_alt_size (a0::a1) = 1 + (exp_alt_size a0 + exp3_alt_size a1) +End + +Triviality exp3_alt_size[simp]: + exp3_alt_size xs = list_size exp_alt_size xs +Proof + Induct_on `xs` \\ simp [] +QED + Definition evaluate_def[nocompute]: (evaluate ([],env:closSem$v list,^s) = (Rval [],s)) /\ (evaluate (x::y::xs,env,s) = @@ -677,15 +716,12 @@ Definition evaluate_def[nocompute]: | NotThunk => (Rerr (Rabort Rtype_error),s) | IsThunk Evaluated v => (Rval [v],s) | IsThunk NotEvaluated f => - if s.clock = 0 then - (Rerr (Rabort Rtimeout_error),s) - else - case evaluate ([AppUnit (Var None 0)],[f],(dec_clock 1 s)) of - | (Rval vs2,s) => - (case update_thunk vs s.refs vs2 of - | NONE => (Rerr (Rabort Rtype_error),s) - | SOME refs => (Rval vs2,s with refs := refs)) - | (Rerr e,s) => (Rerr e,s)) + (case evaluate ([AppUnit (Var None 0)],[f],s) of + | (Rval vs2,s) => + (case update_thunk vs s.refs vs2 of + | NONE => (Rerr (Rabort Rtype_error),s) + | SOME refs => (Rval vs2,s with refs := refs)) + | (Rerr e,s) => (Rerr e,s))) else (case do_app op (REVERSE vs) s of | Rerr err => (Rerr err,s) @@ -756,7 +792,7 @@ Definition evaluate_def[nocompute]: | res => res) Termination WF_REL_TAC `(inv_image (measure I LEX measure I LEX measure I) - (\x. case x of INL (xs,env,s) => (s.clock,list_size exp_size xs,0) + (\x. case x of INL (xs,env,s) => (s.clock,list_size exp_alt_size xs,0) | INR (l,f,args,s) => (s.clock,0,LENGTH args)))` \\ rpt strip_tac \\ simp[dec_clock_def] @@ -767,7 +803,8 @@ Termination \\ imp_res_tac dest_closure_length \\ imp_res_tac LESS_EQ_dec_clock \\ FULL_SIMP_TAC (srw_ss()) [] - \\ decide_tac + \\ simp [AppUnit_def] + \\ IF_CASES_TAC \\ gvs [] End Theorem evaluate_app_NIL[simp] = diff --git a/compiler/backend/semantics/dataSemScript.sml b/compiler/backend/semantics/dataSemScript.sml index 413edc2a09..b89bcaa3fa 100644 --- a/compiler/backend/semantics/dataSemScript.sml +++ b/compiler/backend/semantics/dataSemScript.sml @@ -1285,33 +1285,34 @@ Definition evaluate_def: | NONE => (SOME (Rerr(Rabort Rtype_error)),s) | SOME env => (NONE, set_var dest v (s with locals := env)))) | IsThunk NotEvaluated f => - (if s.clock = 0 then - (SOME (Rerr(Rabort Rtimeout_error)), flush_state T s) - else - (case find_code (SOME loc) [thunk_v; f] s.code s.stack_frame_sizes of - | NONE => (SOME (Rerr (Rabort Rtype_error)),s) - | SOME (args1,prog,ss) => - (case ret of - | NONE => - (case evaluate (prog, call_env args1 ss (dec_clock s)) of - | (NONE,s) => (SOME (Rerr(Rabort Rtype_error)),s) - | (SOME res,s) => (SOME res,s)) - | SOME (dest,names) => - (case cut_env names s.locals of - | NONE => (SOME (Rerr(Rabort Rtype_error)),s) - | SOME env => - let s1 = call_env args1 ss (push_env env F (dec_clock s)) in - if s.clock = 0 then - (SOME (Rerr(Rabort Rtimeout_error)), - s1 with <| stack := [] ; locals := LN |>) - else - (case fix_clock s1 (evaluate (prog, s1)) of - | (SOME (Rval x),s2) => - (case pop_env s2 of - | NONE => (SOME (Rerr(Rabort Rtype_error)),s2) - | SOME s1 => (NONE, set_var dest x s1)) - | (NONE,s) => (SOME (Rerr(Rabort Rtype_error)),s) - | res => res))))))) /\ + (case find_code (SOME loc) [thunk_v; f] s.code s.stack_frame_sizes of + | NONE => (SOME (Rerr (Rabort Rtype_error)),s) + | SOME (args1,prog,ss) => + (case ret of + | NONE => + (if s.clock = 0 then + (SOME (Rerr(Rabort Rtimeout_error)), + s with <| stack := [] ; locals := LN |>) + else + (case evaluate (prog, call_env args1 ss (dec_clock s)) of + | (NONE,s) => (SOME (Rerr(Rabort Rtype_error)),s) + | (SOME res,s) => (SOME res,s))) + | SOME (dest,names) => + (case cut_env names s.locals of + | NONE => (SOME (Rerr(Rabort Rtype_error)),s) + | SOME env => + let s1 = call_env args1 ss (push_env env F (dec_clock s)) in + if s.clock = 0 then + (SOME (Rerr(Rabort Rtimeout_error)), + s1 with <| stack := [] ; locals := LN |>) + else + (case fix_clock s1 (evaluate (prog, s1)) of + | (SOME (Rval x),s2) => + (case pop_env s2 of + | NONE => (SOME (Rerr(Rabort Rtype_error)),s2) + | SOME s1 => (NONE, set_var dest x s1)) + | (NONE,s) => (SOME (Rerr(Rabort Rtype_error)),s) + | res => res)))))) /\ (evaluate (Call ret dest args handler,s) = case get_vars args s.locals of | NONE => (SOME (Rerr(Rabort Rtype_error)),s) diff --git a/compiler/backend/semantics/flatSemScript.sml b/compiler/backend/semantics/flatSemScript.sml index 61a144e17e..c25f9fda9a 100644 --- a/compiler/backend/semantics/flatSemScript.sml +++ b/compiler/backend/semantics/flatSemScript.sml @@ -656,15 +656,6 @@ Proof Cases_on `x` \\ fs [fix_clock_def] \\ rw [] \\ fs [] QED -Theorem pmatch_rows_Match_exp_size: - !pes s v env e. - pmatch_rows pes s v = Match (env',p,e) ==> - exp_size e < exp3_size pes -Proof - Induct \\ fs [pmatch_rows_def,FORALL_PROD,CaseEq"match_result",CaseEq"bool"] - \\ rw [] \\ res_tac \\ fs [exp_size_def] -QED - Definition is_fresh_type_def: is_fresh_type type_id ctors ⇔ !ctor. ctor ∈ ctors ⇒ !arity id. ctor ≠ ((id, SOME type_id), arity) @@ -723,6 +714,63 @@ Definition AppUnit_def: AppUnit x = flatLang$App None Opapp [x; Con None NONE []] End +Definition exp_alt_size_def[simp]: + exp_alt_size (Raise a0 a1) = 1 + (tra_size a0 + exp_alt_size a1) ∧ + exp_alt_size (Handle a0 a1 a2) = + 1 + (tra_size a0 + (exp_alt_size a1 + exp3_alt_size a2)) ∧ + exp_alt_size (Lit a0 a1) = 1 + (tra_size a0 + lit_size a1) ∧ + exp_alt_size (Con a0 a1 a2) = + 1 + + (tra_size a0 + + (option_size (pair_size (λx. x) (option_size (λx. x))) a1 + + exp6_alt_size a2)) ∧ + exp_alt_size (Var_local a0 a1) = 1 + (tra_size a0 + list_size char_size a1) ∧ + exp_alt_size (Fun a0 a1 a2) = + 1 + (list_size char_size a0 + (list_size char_size a1 + exp_alt_size a2)) ∧ + exp_alt_size (App a0 a1 a2) = + 1 + (tra_size a0 + (op_size a1 + exp6_alt_size a2)) + + (if a1 = ThunkOp ForceThunk then 100 else 0) ∧ + exp_alt_size (If a0 a1 a2 a3) = + 1 + (tra_size a0 + (exp_alt_size a1 + (exp_alt_size a2 + exp_alt_size a3))) ∧ + exp_alt_size (Mat a0 a1 a2) = + 1 + (tra_size a0 + (exp_alt_size a1 + exp3_alt_size a2)) ∧ + exp_alt_size (Let a0 a1 a2 a3) = + 1 + + (tra_size a0 + + (option_size (list_size char_size) a1 + (exp_alt_size a2 + exp_alt_size a3))) ∧ + exp_alt_size (Letrec a0 a1 a2) = + 1 + (list_size char_size a0 + (exp1_alt_size a1 + exp_alt_size a2)) ∧ + exp1_alt_size [] = 0 ∧ + exp1_alt_size (a0::a1) = 1 + (exp2_alt_size a0 + exp1_alt_size a1) ∧ + exp2_alt_size (a0,a1) = 1 + (list_size char_size a0 + exp4_alt_size a1) ∧ + exp3_alt_size [] = 0 ∧ + exp3_alt_size (a0::a1) = 1 + (exp5_alt_size a0 + exp3_alt_size a1) ∧ + exp4_alt_size (a0,a1) = 1 + (list_size char_size a0 + exp_alt_size a1) ∧ + exp5_alt_size (a0,a1) = 1 + (pat_size a0 + exp_alt_size a1) ∧ exp6_alt_size [] = 0 ∧ + exp6_alt_size (a0::a1) = 1 + (exp_alt_size a0 + exp6_alt_size a1) +End + +Theorem exp6_alt_size: + exp6_alt_size xs = LENGTH xs + SUM (MAP exp_alt_size xs) +Proof + Induct_on `xs` \\ simp [] +QED + +Theorem pmatch_rows_Match_exp_alt_size: + !pes s v env e. + pmatch_rows pes s v = Match (env',p,e) ==> + exp_alt_size e < exp3_alt_size pes +Proof + Induct \\ fs [pmatch_rows_def,FORALL_PROD,CaseEq"match_result",CaseEq"bool"] + \\ rw [] \\ res_tac \\ fs [] +QED + +Definition dec_alt_size_def[simp]: + dec_alt_size (Dlet a) = 1 + exp_alt_size a ∧ + dec_alt_size (Dtype a0 a1) = 1 + (a0 + spt_size (λx. x) a1) ∧ + dec_alt_size (Dexn a0 a1) = 1 + (a0 + a1) +End + Definition evaluate_def: (evaluate (env:v flatSem$environment) ^s ([]:flatLang$exp list) = (s,Rval [])) ∧ @@ -793,16 +841,13 @@ Definition evaluate_def: | NotThunk => (s, Rerr (Rabort Rtype_error)) | IsThunk Evaluated v => (s, Rval [v]) | IsThunk NotEvaluated f => - if s.clock = 0 then - (s, Rerr (Rabort Rtimeout_error)) - else - case evaluate <| v := [("f",f)] |> (dec_clock s) - [AppUnit (Var_local None "f")] of - | (s, Rval vs2) => - (case update_thunk vs s.refs vs2 of - | NONE => (s, Rerr (Rabort Rtype_error)) - | SOME refs => (s with refs := refs, Rval vs2)) - | (s, Rerr e) => (s, Rerr e)) + (case evaluate <| v := [("f",f)] |> s + [AppUnit (Var_local None "f")] of + | (s, Rval vs2) => + (case update_thunk vs s.refs vs2 of + | NONE => (s, Rerr (Rabort Rtype_error)) + | SOME refs => (s with refs := refs, Rval vs2)) + | (s, Rerr e) => (s, Rerr e))) else (case (do_app s op (REVERSE vs)) of | NONE => (s, Rerr (Rabort Rtype_error)) @@ -862,16 +907,16 @@ Definition evaluate_def: Termination wf_rel_tac `inv_image ($< LEX $<) (\x. case x of - | INL (env,s,exps) => (s.clock, SUM (MAP exp_size exps) + LENGTH exps) - | (INR(INL(s,d))) => (s.clock,dec_size d + 1) - | (INR(INR(s,ds))) => (s.clock,SUM (MAP dec_size ds) + LENGTH ds + 1))` - \\ simp [exp_size_def, dec_clock_def] + | INL (env,s,exps) => (s.clock, SUM (MAP exp_alt_size exps) + LENGTH exps) + | (INR(INL(s,d))) => (s.clock,dec_alt_size d + 1) + | (INR(INR(s,ds))) => (s.clock,SUM (MAP dec_alt_size ds) + LENGTH ds + 1))` + \\ simp [dec_clock_def] \\ rw [] \\ imp_res_tac fix_clock_IMP \\ imp_res_tac do_if_either_or - \\ imp_res_tac pmatch_rows_Match_exp_size + \\ imp_res_tac pmatch_rows_Match_exp_alt_size \\ fs [] - \\ simp [MAP_REVERSE, SUM_REVERSE, exp6_size] + \\ simp [MAP_REVERSE, SUM_REVERSE, exp6_alt_size, AppUnit_def, char_size_def] End val op_thms = { nchotomy = op_nchotomy, case_def = op_case_def}; diff --git a/semantics/evaluateScript.sml b/semantics/evaluateScript.sml index 7a0a587e56..38d16451b1 100644 --- a/semantics/evaluateScript.sml +++ b/semantics/evaluateScript.sml @@ -114,17 +114,16 @@ Definition evaluate_def[nocompute]: | NotThunk => (st', Rerr (Rabort Rtype_error)) | IsThunk Evaluated v => (st', Rval [v]) | IsThunk NotEvaluated f => - if st'.clock = 0 then (st', Rerr (Rabort Rtimeout_error)) else - case do_opapp [f; Conv NONE []] of - | SOME (env',e) => - if (dec_clock st').clock = 0 then (dec_clock st', Rerr (Rabort Rtimeout_error)) else - (case evaluate (dec_clock (dec_clock st')) env' [e] of - | (st2, Rval vs2) => - (case update_thunk (REVERSE vs) st2.refs vs2 of - | NONE => (st2, Rerr (Rabort Rtype_error)) - | SOME refs => (st2 with refs := refs, Rval vs2)) - | (st2, Rerr e) => (st2, Rerr e)) - | NONE => (dec_clock st', Rerr (Rabort Rtype_error))) + (case do_opapp [f; Conv NONE []] of + | SOME (env',e) => + if st'.clock = 0 then (st', Rerr (Rabort Rtimeout_error)) else + (case evaluate (dec_clock st') env' [e] of + | (st2, Rval vs2) => + (case update_thunk (REVERSE vs) st2.refs vs2 of + | NONE => (st2, Rerr (Rabort Rtype_error)) + | SOME refs => (st2 with refs := refs, Rval vs2)) + | (st2, Rerr e) => (st2, Rerr e)) + | NONE => (dec_clock st', Rerr (Rabort Rtype_error)))) | EvalOp => (case fix_clock st' (do_eval_res (REVERSE vs) st') of (st1, Rval (env1, decs)) => From e4eb73e8684d4acabd3d55a78d614067990d3a7b Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 18 Sep 2025 13:11:55 +0300 Subject: [PATCH 091/112] Fixes for changes in evaluateScirpt --- .../backend/proofs/source_evalProofScript.sml | 32 ++----------------- semantics/evaluateScript.sml | 2 +- semantics/proofs/evaluatePropsScript.sml | 24 -------------- 3 files changed, 4 insertions(+), 54 deletions(-) diff --git a/compiler/backend/proofs/source_evalProofScript.sml b/compiler/backend/proofs/source_evalProofScript.sml index d0fc6e4f50..892ff0319f 100644 --- a/compiler/backend/proofs/source_evalProofScript.sml +++ b/compiler/backend/proofs/source_evalProofScript.sml @@ -1033,18 +1033,6 @@ Proof first_x_assum drule \\ rw [] \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs [] \\ gvs[do_opapp_cases] \\ irule_at Any EQ_REFL >> simp[]) - >- ( - gvs [oneline dest_thunk_def, AllCaseEqs(), oneline store_lookup_def] - \\ `n < LENGTH t''.refs ∧ - ∃a. EL n t''.refs = Thunk NotEvaluated a ∧ - v_rel (orac_s t''.eval_state) v a` by ( - gvs [s_rel_def, LIST_REL_EL_EQN] - \\ first_x_assum drule \\ rw [] - \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs [] >> - gvs[do_opapp_cases, PULL_EXISTS] >> - imp_res_tac s_rel_def >> gvs[] >> - drule s_rel_clock >> simp[dec_clock_def] >> strip_tac - ) >- ( gvs [oneline dest_thunk_def, AllCaseEqs(), oneline store_lookup_def] \\ `n < LENGTH t''.refs ∧ @@ -1057,7 +1045,6 @@ Proof >- ( imp_res_tac s_rel_def >> gvs[] >> drule s_rel_clock >> simp[dec_clock_def] >> strip_tac >> - dxrule s_rel_clock >> simp[dec_clock_def] >> strip_tac >> last_x_assum dxrule >> simp[] >> qmatch_goalsub_abbrev_tac ‘evaluate _ new_env’ >> disch_then $ qspec_then ‘new_env’ mp_tac >> impl_tac @@ -1084,7 +1071,6 @@ Proof >- ( imp_res_tac s_rel_def >> gvs[] >> drule s_rel_clock >> simp[dec_clock_def] >> strip_tac >> - dxrule s_rel_clock >> simp[dec_clock_def] >> strip_tac >> last_x_assum dxrule >> simp[] >> qmatch_goalsub_abbrev_tac ‘evaluate _ new_env’ >> disch_then $ qspec_then ‘new_env’ mp_tac >> impl_tac @@ -1128,7 +1114,6 @@ Proof imp_res_tac s_rel_def >> gvs[] >> irule_at Any OR_INTRO_THM2 >> drule s_rel_clock >> simp[dec_clock_def] >> strip_tac >> - dxrule s_rel_clock >> simp[dec_clock_def] >> strip_tac >> last_x_assum dxrule >> simp[] >> qmatch_goalsub_abbrev_tac ‘evaluate _ new_env’ >> disch_then $ qspec_then ‘new_env’ mp_tac >> impl_tac @@ -1139,7 +1124,6 @@ Proof imp_res_tac s_rel_def >> gvs[] >> irule_at Any OR_INTRO_THM2 >> drule s_rel_clock >> simp[dec_clock_def] >> strip_tac >> - dxrule s_rel_clock >> simp[dec_clock_def] >> strip_tac >> last_x_assum dxrule >> simp[] >> qmatch_goalsub_abbrev_tac ‘evaluate _ new_env’ >> disch_then $ qspec_then ‘new_env’ mp_tac >> impl_tac @@ -1789,13 +1773,6 @@ Proof DECIDE_TAC QED -Triviality less_sub_2_cases: - k <= clock /\ ¬(clock ≤ 1) ==> - (k = clock \/ k = clock - 1 \/ k <= clock - 2n) -Proof - DECIDE_TAC -QED - Theorem evaluate_record_suffix: (! ^s env exps s' res. evaluate s env exps = (s', res) /\ @@ -1865,12 +1842,9 @@ Proof \\ simp [combine_dec_result_def] >>~ [`getOpClass op = Force`] >- ( - gvs [AllCaseEqs(), dec_clock_def] >> - imp_res_simp_tac evaluate_is_record_forward >> gvs [] - >- simp[record_forward_refl] - >- simp[DISJ_EQ_IMP, record_forward_refl] >> - drule_then (drule_then assume_tac) less_sub_2_cases >> gvs [] - ) + gvs [AllCaseEqs(), dec_clock_def] + \\ drule_then (drule_then assume_tac) less_sub_1_cases \\ gvs [] + \\ imp_res_simp_tac evaluate_is_record_forward \\ gvs []) >- ( gvs [AllCaseEqs(), dec_clock_def] \\ imp_res_simp_tac evaluate_is_record_forward \\ gvs [] diff --git a/semantics/evaluateScript.sml b/semantics/evaluateScript.sml index 38d16451b1..8e05a164da 100644 --- a/semantics/evaluateScript.sml +++ b/semantics/evaluateScript.sml @@ -123,7 +123,7 @@ Definition evaluate_def[nocompute]: | NONE => (st2, Rerr (Rabort Rtype_error)) | SOME refs => (st2 with refs := refs, Rval vs2)) | (st2, Rerr e) => (st2, Rerr e)) - | NONE => (dec_clock st', Rerr (Rabort Rtype_error)))) + | NONE => (st', Rerr (Rabort Rtype_error)))) | EvalOp => (case fix_clock st' (do_eval_res (REVERSE vs) st') of (st1, Rval (env1, decs)) => diff --git a/semantics/proofs/evaluatePropsScript.sml b/semantics/proofs/evaluatePropsScript.sml index 8df6b06691..b2f01887a2 100644 --- a/semantics/proofs/evaluatePropsScript.sml +++ b/semantics/proofs/evaluatePropsScript.sml @@ -1404,27 +1404,3 @@ Proof \\ irule_at (Pos hd) EQ_REFL \\ gvs [dec_clock_def,ADD1] QED - -Theorem evaluate_Force_alt: - evaluate st env [App (ThunkOp ForceThunk) es] = - case evaluate st env (REVERSE es) of - | (st', Rval vs) => ( - case dest_thunk (REVERSE vs) st'.refs of - | BadRef => (st', Rerr (Rabort Rtype_error)) - | NotThunk => (st', Rerr (Rabort Rtype_error)) - | IsThunk Evaluated v => (st', Rval [v]) - | IsThunk NotEvaluated f => ( - if st'.clock = 0 then (st', Rerr (Rabort Rtimeout_error)) else - case evaluate (dec_clock st') (sing_env "f" f) [App Opapp [Var (Short "f"); Con NONE []]] of - | (st2, Rval vs2) => ( - case update_thunk (REVERSE vs) st2.refs vs2 of - | NONE => (st2, Rerr (Rabort Rtype_error)) - | SOME refs => (st2 with refs := refs, Rval vs2)) - | res => res)) - | res => res -Proof - simp[Once evaluate_def] >> - ntac 4 (TOP_CASE_TAC >> simp[]) >> - simp[evaluate_def, sing_env_def, do_con_check_def, build_conv_def] >> - rpt (TOP_CASE_TAC >> simp[]) -QED From 317631b48a53b8c48855ccac4921f34847d6801d Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 18 Sep 2025 14:34:52 +0300 Subject: [PATCH 092/112] Fixes for changes in flatSemScript --- .../backend/proofs/flat_elimProofScript.sml | 14 +++++--------- .../backend/proofs/flat_patternProofScript.sml | 13 ++----------- .../proofs/source_to_flatProofScript.sml | 18 ------------------ compiler/backend/semantics/flatPropsScript.sml | 1 + 4 files changed, 8 insertions(+), 38 deletions(-) diff --git a/compiler/backend/proofs/flat_elimProofScript.sml b/compiler/backend/proofs/flat_elimProofScript.sml index 714e566bd6..7765e0ad0c 100644 --- a/compiler/backend/proofs/flat_elimProofScript.sml +++ b/compiler/backend/proofs/flat_elimProofScript.sml @@ -976,7 +976,7 @@ Proof >- ( Cases_on `op = ThunkOp ForceThunk` >> gvs [] >- ( - gvs [AllCaseEqs(), dec_clock_def, dest_GlobalVarLookup_def] + gvs [AllCaseEqs(), dec_clock_def, dest_GlobalVarLookup_def, PULL_EXISTS] >- ( gvs [oneline dest_thunk_def, AllCaseEqs(), semanticPrimitivesTheory.store_lookup_def, flat_state_rel_def, @@ -984,16 +984,12 @@ Proof first_x_assum drule >> gvs [] >> rw [] >> gvs [find_sem_prim_res_globals_def, find_v_globals_def] >> drule_all find_refs_globals_EL >> rw []) - >- gvs [oneline dest_thunk_def, AllCaseEqs(), - semanticPrimitivesTheory.store_lookup_def, flat_state_rel_def, - find_sem_prim_res_globals_def, find_result_globals_def] >- ( gvs [oneline dest_thunk_def, AllCaseEqs(), semanticPrimitivesTheory.store_lookup_def, flat_state_rel_def] >> simp [PULL_EXISTS] >> last_x_assum $ qspecl_then - [`reachable`, `new_removed_state with clock := - new_removed_state.clock - 1`] mp_tac >> + [`reachable`, `new_removed_state`] mp_tac >> impl_tac >- ( gvs [AppUnit_def, find_lookups_def, dest_GlobalVarLookup_def, @@ -1013,8 +1009,7 @@ Proof gvs [oneline dest_thunk_def, AllCaseEqs(), semanticPrimitivesTheory.store_lookup_def, flat_state_rel_def] >> last_x_assum $ qspecl_then - [`reachable`, `new_removed_state with clock := - new_removed_state.clock - 1`] mp_tac >> + [`reachable`, `new_removed_state`] mp_tac >> impl_tac >- ( gvs [AppUnit_def, find_lookups_def, dest_GlobalVarLookup_def, @@ -1022,7 +1017,8 @@ Proof EVERY_EL] >> first_x_assum drule >> rw [] >> drule_all find_refs_globals_EL >> rw []) >> - rw [])) >> + rw [] >> + goal_assum drule >> simp [])) >> Cases_on `do_app q op (REVERSE a)` >> fs[] >> PairCases_on `x` >> fs[] >> rveq >> drule (GEN_ALL do_app_SOME_flat_state_rel) >> diff --git a/compiler/backend/proofs/flat_patternProofScript.sml b/compiler/backend/proofs/flat_patternProofScript.sml index 91c7930e43..b5e0ed8b35 100644 --- a/compiler/backend/proofs/flat_patternProofScript.sml +++ b/compiler/backend/proofs/flat_patternProofScript.sml @@ -1769,13 +1769,6 @@ Proof qpat_x_assum `∀n. n < LENGTH t2.refs ⇒ _` drule \\ rw []) \\ gvs [] \\ Cases_on `EL n t2.refs` \\ gvs []) - >- ( - gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS, - store_lookup_def] - \\ rgs [Once v_rel_cases] - \\ gvs [state_rel_def, LIST_REL_EL_EQN] - \\ qpat_x_assum `∀n. n < LENGTH t2.refs ⇒ _` drule \\ rw [] - \\ Cases_on `EL n t2.refs` \\ gvs []) >- ( gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS, store_lookup_def] @@ -1787,8 +1780,7 @@ Proof \\ Cases_on `EL n t2.refs` \\ gvs []) \\ gvs [] \\ simp [PULL_EXISTS] \\ gvs [AppUnit_def, compile_exp_def, PULL_EXISTS, dec_name_to_num_def] - \\ last_x_assum $ qspecl_then [`1`, `<|v := [("f",a)]|>`, - `t2 with clock := t2.clock - 1`] mp_tac + \\ last_x_assum $ qspecl_then [`1`, `<|v := [("f",a)]|>`, `t2`] mp_tac \\ impl_tac >- gvs [env_rel_def, ALOOKUP_rel_def, OPTREL_def, state_rel_def] \\ rw [] \\ gvs [] @@ -1817,8 +1809,7 @@ Proof \\ qpat_x_assum `∀n. n < LENGTH t2.refs ⇒ _` drule \\ rw [] \\ Cases_on `EL n t2.refs` \\ gvs []) \\ gvs [] \\ gvs [AppUnit_def, compile_exp_def, PULL_EXISTS, dec_name_to_num_def] - \\ last_x_assum $ qspecl_then [`1`, `<|v := [("f",a)]|>`, - `t2 with clock := t2.clock - 1`] mp_tac + \\ last_x_assum $ qspecl_then [`1`, `<|v := [("f",a)]|>`, `t2`] mp_tac \\ impl_tac >- gvs [env_rel_def, ALOOKUP_rel_def, OPTREL_def, state_rel_def] \\ rw [] \\ gvs [] diff --git a/compiler/backend/proofs/source_to_flatProofScript.sml b/compiler/backend/proofs/source_to_flatProofScript.sml index cfa36966c0..fb3b03e786 100644 --- a/compiler/backend/proofs/source_to_flatProofScript.sml +++ b/compiler/backend/proofs/source_to_flatProofScript.sml @@ -4239,22 +4239,6 @@ Proof first_x_assum drule >> gvs[] >> rw[Once sv_rel_cases]) >> simp[REWRITE_RULE [ADD1] EL, Once result_rel_cases] >> goal_assum drule >> rw[]) - >- ( - gvs[astOp_to_flatOp_def, evaluate_def, compile_exps_reverse, - AllCaseEqs()] >> - qpat_x_assum `result_rel _ _ _ r_i1` mp_tac >> - rw[Once result_rel_cases] >> - gvs[oneline semanticPrimitivesTheory.dest_thunk_def, AllCaseEqs()] >> - rgs[Once v_rel_cases] >> gvs[] >> - simp[dest_thunk_def, AllCaseEqs(), PULL_EXISTS] >> - gvs[store_lookup_def, s_rel_cases, LIST_REL_EL_EQN] >> - `n + 1 < LENGTH s'_i1.refs` by (Cases_on `s'_i1.refs` >> gvs[]) >> - gvs[] >> - `∃v'. EL n (TL s'_i1.refs) = Thunk NotEvaluated v' ∧ - v_rel genv' v v'` by ( - first_x_assum drule >> gvs[] >> rw[Once sv_rel_cases]) >> - simp[REWRITE_RULE [ADD1] EL, Once result_rel_cases] >> - goal_assum drule >> rw[]) >- ( gvs[astOp_to_flatOp_def, evaluate_def, compile_exps_reverse, AllCaseEqs()] >> @@ -4296,7 +4280,6 @@ Proof drule do_opapp >> simp[PULL_EXISTS] >> disch_then drule >> simp[Once v_rel_cases] >> strip_tac >> gvs[] >> dxrule invariant_dec_clock >> strip_tac >> - dxrule invariant_dec_clock >> strip_tac >> gvs[evaluateTheory.dec_clock_def, flatSemTheory.dec_clock_def] >> last_x_assum drule_all >> disch_then $ qspec_then ‘t1’ assume_tac >> gvs[] >> gvs[Once result_rel_cases] >> @@ -4359,7 +4342,6 @@ Proof drule do_opapp >> simp[PULL_EXISTS] >> disch_then drule >> simp[Once v_rel_cases] >> strip_tac >> gvs[] >> dxrule invariant_dec_clock >> strip_tac >> - dxrule invariant_dec_clock >> strip_tac >> gvs[evaluateTheory.dec_clock_def, flatSemTheory.dec_clock_def] >> last_x_assum drule_all >> disch_then $ qspec_then ‘t1’ assume_tac >> gvs[] >> qpat_x_assum `result_rel _ _ _ r_i1` mp_tac >> rw[Once result_rel_cases] >> diff --git a/compiler/backend/semantics/flatPropsScript.sml b/compiler/backend/semantics/flatPropsScript.sml index 1590abcc63..c77444d478 100644 --- a/compiler/backend/semantics/flatPropsScript.sml +++ b/compiler/backend/semantics/flatPropsScript.sml @@ -480,6 +480,7 @@ Proof \\ rw [] \\ fs [] \\ rw [] \\ fs [] \\ rfs [] \\ fsrw_tac [SATISFY_ss] [IS_PREFIX_TRANS] + \\ gvs [AppUnit_def] \\ metis_tac [IS_PREFIX_TRANS, FST, PAIR, evaluate_io_events_mono, with_clock_ffi, From de31c41fd30dbed32969c5947423185011220a12 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 18 Sep 2025 15:31:20 +0300 Subject: [PATCH 093/112] Fixes for changes in closSemScript --- .../proofs/clos_annotateProofScript.sml | 3 +- .../backend/proofs/clos_callProofScript.sml | 29 +++---------------- .../backend/proofs/clos_interpProofScript.sml | 22 +++++++------- .../backend/proofs/clos_knownProofScript.sml | 28 ------------------ .../backend/semantics/closPropsScript.sml | 8 ++--- 5 files changed, 19 insertions(+), 71 deletions(-) diff --git a/compiler/backend/proofs/clos_annotateProofScript.sml b/compiler/backend/proofs/clos_annotateProofScript.sml index e399f74a92..85d48311b2 100644 --- a/compiler/backend/proofs/clos_annotateProofScript.sml +++ b/compiler/backend/proofs/clos_annotateProofScript.sml @@ -885,8 +885,7 @@ Proof \\ qpat_x_assum `opt_rel (ref_rel v_rel) _ _` mp_tac \\ simp [oneline opt_rel_def] \\ CASE_TAC \\ gvs [PULL_EXISTS] \\ imp_res_tac state_rel_clocks_eqs \\ gvs [PULL_EXISTS] - \\ last_x_assum - $ qspecl_then [`[b]`, `dec_clock 1 t2`, `0`, `1`, `i`] mp_tac + \\ last_x_assum $ qspecl_then [`[b]`, `t2`, `0`, `1`, `i`] mp_tac \\ ( gvs [] \\ impl_tac >- ( diff --git a/compiler/backend/proofs/clos_callProofScript.sml b/compiler/backend/proofs/clos_callProofScript.sml index edbfdeb3ef..db9d848c09 100644 --- a/compiler/backend/proofs/clos_callProofScript.sml +++ b/compiler/backend/proofs/clos_callProofScript.sml @@ -3159,36 +3159,23 @@ Proof \\ first_x_assum drule \\ rw []) \\ goal_assum drule \\ gvs [] \\ drule_all state_rel_flookup_refs \\ rw [] \\ gvs []) - >- ( - gvs [v_rel_def] - \\ rpt (goal_assum drule \\ gvs []) - \\ drule_all state_rel_flookup_refs \\ rw [] \\ gvs [] - \\ imp_res_tac state_rel_clock \\ gvs []) >- ( gvs [v_rel_def] \\ gvs [AppUnit_def, calls_def, code_locs_def] \\ drule_all_then assume_tac state_rel_flookup_refs \\ gvs [] - \\ `state_rel g2 l2 (dec_clock 1 r) (dec_clock 1 t)` by ( - gvs [state_rel_def, dec_clock_def]) - \\ first_x_assum $ drule_at (Pat `state_rel _ _ (dec_clock _ _) _`) - \\ gvs [] + \\ first_x_assum $ drule_at (Pat `state_rel _ _ _ _`) \\ gvs [] \\ disch_then $ qspecl_then [`g`, `[b]`] mp_tac \\ impl_tac >- ( rw [] - >- gvs [code_inv_def, dec_clock_def] >- ( gvs [dec_clock_def, wfv_state_def, FEVERY_ALL_FLOOKUP] \\ first_x_assum drule \\ rw []) - >- gvs [wfv_state_def, dec_clock_def] >- (irule calls_wfg \\ metis_tac[]) >- imp_res_tac subg_trans >- gvs [env_rel_def, dec_clock_def] >- ( - `(dec_clock 1 t).code = t.code` - by gvs [state_rel_def, dec_clock_def] - \\ gvs [] - \\ irule code_includes_SUBMAP + irule code_includes_SUBMAP \\ goal_assum $ drule_at Any \\ rw [] \\ imp_res_tac evaluate_mono \\ gvs [])) \\ rw [] \\ gvs [] @@ -3225,27 +3212,19 @@ Proof gvs [v_rel_def] \\ gvs [AppUnit_def, calls_def, code_locs_def] \\ drule_all_then assume_tac state_rel_flookup_refs \\ gvs [] - \\ `state_rel g2 l2 (dec_clock 1 r) (dec_clock 1 t)` by ( - gvs [state_rel_def, dec_clock_def]) - \\ first_x_assum $ drule_at (Pat `state_rel _ _ (dec_clock _ _) _`) - \\ gvs [] + \\ first_x_assum $ drule_at (Pat `state_rel _ _ _ _`) \\ gvs [] \\ disch_then $ qspecl_then [`g`, `[b]`] mp_tac \\ impl_tac >- ( rw [] - >- gvs [code_inv_def, dec_clock_def] >- ( gvs [dec_clock_def, wfv_state_def, FEVERY_ALL_FLOOKUP] \\ first_x_assum drule \\ rw []) - >- gvs [wfv_state_def, dec_clock_def] >- (irule calls_wfg \\ metis_tac[]) >- imp_res_tac subg_trans >- gvs [env_rel_def, dec_clock_def] >- ( - `(dec_clock 1 t).code = t.code` - by gvs [state_rel_def, dec_clock_def] - \\ gvs [] - \\ irule code_includes_SUBMAP + irule code_includes_SUBMAP \\ goal_assum $ drule_at Any \\ rw [] \\ imp_res_tac evaluate_mono \\ gvs [])) \\ rw [] \\ gvs [] diff --git a/compiler/backend/proofs/clos_interpProofScript.sml b/compiler/backend/proofs/clos_interpProofScript.sml index d4bd047dbd..b6807b8e78 100644 --- a/compiler/backend/proofs/clos_interpProofScript.sml +++ b/compiler/backend/proofs/clos_interpProofScript.sml @@ -828,7 +828,7 @@ Proof \\ gvs [evaluate_def,CaseEq"prod",PULL_EXISTS] \\ first_assum $ drule_at $ Pos $ el 3 \\ disch_then $ drule_at $ Pos last - \\ impl_tac >- (fs [exp_size_def] \\ strip_tac \\ gvs []) + \\ impl_tac >- (fs [] \\ strip_tac \\ gvs []) \\ strip_tac \\ fs [] \\ reverse (gvs [CaseEq"result"]) >- (qexists_tac ‘ck’ \\ fs []) @@ -837,7 +837,7 @@ Proof \\ first_assum $ drule_at $ Pos $ el 3 \\ disch_then $ drule_at $ Pos last \\ imp_res_tac evaluate_clock \\ fs [] - \\ impl_tac >- (fs [exp_size_def] \\ strip_tac \\ gvs []) + \\ impl_tac >- (fs [] \\ strip_tac \\ gvs []) \\ strip_tac \\ fs [] \\ qpat_x_assum ‘evaluate (xs,_) = _’ assume_tac \\ drule evaluate_add_clock \\ fs [] @@ -848,9 +848,9 @@ Proof \\ first_assum $ drule_at $ Pos $ el 3 \\ disch_then $ drule_at $ Pos last \\ impl_tac >- - (fs [exp_size_def] + (fs [] \\ rw [] \\ imp_res_tac evaluate_IMP_LENGTH \\ fs [] - \\ qsuff_tac ‘LENGTH xs ≤ exp3_size xs’ >- fs [] + \\ qsuff_tac ‘LENGTH xs ≤ exp3_alt_size xs’ >- fs [] \\ qid_spec_tac ‘xs’ \\ Induct \\ fs []) \\ strip_tac \\ qpat_x_assum ‘evaluate (xs,_) = _’ assume_tac @@ -964,7 +964,9 @@ Proof \\ gvs [evaluate_def,CaseEq"prod",PULL_EXISTS] \\ first_assum $ drule_at $ Pos $ el 3 \\ disch_then $ drule_at $ Pos last - \\ impl_tac >- (fs [exp_size_def,dec_clock_def] \\ strip_tac \\ gvs []) + \\ impl_tac >- ( + conj_tac >- (IF_CASES_TAC \\ gvs []) + \\ strip_tac \\ gvs []) \\ strip_tac \\ reverse $ gvs [CaseEq"result"] >- (qexists_tac ‘ck’ \\ fs []) @@ -1053,17 +1055,13 @@ Proof rw [] \\ drule evaluate_add_clock \\ gvs []) \\ gvs [] \\ imp_res_tac state_rel_refs_clocks_eqs \\ gvs [PULL_EXISTS] >- (qexists `0` \\ gvs [state_rel_def]) - >- (qexists `0` \\ gvs [state_rel_def]) \\ ( - last_x_assum $ qspecl_then [`[AppUnit (Var None 0)]`, - `s' with clock := t2.clock - 1`] mp_tac + last_x_assum $ qspecl_then [`[AppUnit (Var None 0)]`, `s'`] mp_tac \\ gvs [GSYM PULL_FORALL] \\ impl_tac - >- (imp_res_tac evaluate_clock \\ gvs []) + >- (imp_res_tac evaluate_clock \\ gvs [AppUnit_def]) \\ disch_then $ qspec_then `[v]` mp_tac \\ gvs [dec_clock_def] - \\ disch_then $ qspec_then `dec_clock 1 t2` mp_tac \\ gvs [dec_clock_def] - \\ impl_tac - >- gvs [state_rel_def] + \\ disch_then $ qspec_then `t2` mp_tac \\ gvs [dec_clock_def] \\ rw [] \\ goal_assum drule \\ gvs [] \\ imp_res_tac state_rel_update_thunk \\ rw [])) diff --git a/compiler/backend/proofs/clos_knownProofScript.sml b/compiler/backend/proofs/clos_knownProofScript.sml index 562d30a19c..71dee3ce8a 100644 --- a/compiler/backend/proofs/clos_knownProofScript.sml +++ b/compiler/backend/proofs/clos_knownProofScript.sml @@ -3739,23 +3739,13 @@ Proof v_rel c (next_g s) v w` by ( gvs [state_rel_def, fmap_rel_def, FLOOKUP_DEF] \\ first_x_assum drule \\ rw []) \\ gvs []) - >- ( - `∃w. FLOOKUP t.refs ptr = SOME (Thunk NotEvaluated w) ∧ - v_rel c (next_g s) v w` by ( - gvs [state_rel_def, fmap_rel_def, FLOOKUP_DEF] - \\ first_x_assum drule \\ rw []) \\ gvs [] - \\ `t.clock = 0` by gvs [state_rel_def] \\ gvs []) >- ( `∃w. FLOOKUP t.refs ptr = SOME (Thunk NotEvaluated w) ∧ v_rel c (next_g s1) v w` by ( gvs [state_rel_def, fmap_rel_def, FLOOKUP_DEF] \\ first_x_assum drule \\ rw []) \\ gvs [PULL_EXISTS] \\ simp [GSYM PULL_EXISTS] \\ rw [] - >- gvs [state_rel_def] \\ gvs [PULL_EXISTS] - \\ `state_rel c (next_g (dec_clock 1 s1)) (dec_clock 1 s1) - (dec_clock 1 t)` - by gvs [state_rel_def, dec_clock_def, next_g_def] \\ last_x_assum $ drule_at (Pat `state_rel _ _ _`) \\ `known c [AppUnit (Var None 0)] [Other] g0 = ([(AppUnit (Var None 0),Other)],g0)` @@ -3778,11 +3768,6 @@ Proof \\ gvs [co_every_Fn_vs_NONE_shift_seq]) >- gvs [AppUnit_def, dec_clock_def, mglobals_disjoint_def, op_gbag_def] - >- ( - qpat_x_assum `evaluate (_,_,s0) = _` assume_tac - \\ drule evaluate_IMP_shift_seq \\ rw [] - \\ gvs [oracle_gapprox_disjoint_shift_seq, dec_clock_def, next_g_def]) - >- gvs [dec_clock_def, state_oracle_mglobals_disjoint_def] >- gvs [AppUnit_def] >- ( qpat_x_assum `evaluate (_,_,s0) = _` assume_tac @@ -3796,7 +3781,6 @@ Proof qpat_x_assum `evaluate (_,_,s0) = _` assume_tac \\ drule evaluate_IMP_shift_seq \\ rw [] \\ gvs [oracle_state_sgc_free_shift_seq]) - >- gvs [next_g_def] >- ( gvs [next_g_def, dec_clock_def] \\ qpat_x_assum `evaluate (_,_,s0) = _` assume_tac @@ -3815,7 +3799,6 @@ Proof \\ qmatch_asmsub_abbrev_tac `fv1 v' exp` \\ `fv v' [exp] ⇔ v' = 0` by (unabbrev_all_tac \\ gvs [fv_def]) \\ gvs []) - >- gvs [next_g_def] >- ( qpat_x_assum `evaluate (_,_,s0) = _` assume_tac \\ drule evaluate_IMP_shift_seq \\ rw [] @@ -3834,10 +3817,6 @@ Proof gvs [state_rel_def, fmap_rel_def, FLOOKUP_DEF] \\ first_x_assum drule \\ rw []) \\ gvs [PULL_EXISTS] \\ simp [GSYM PULL_EXISTS] \\ rw [] - \\ `t.clock ≠ 0` by gvs [state_rel_def] \\ gvs [PULL_EXISTS] - \\ `state_rel c (next_g (dec_clock 1 s1)) (dec_clock 1 s1) - (dec_clock 1 t)` - by gvs [state_rel_def, dec_clock_def, next_g_def] \\ last_x_assum $ drule_at (Pat `state_rel _ _ _`) \\ `known c [AppUnit (Var None 0)] [Other] g0 = ([(AppUnit (Var None 0),Other)],g0)` @@ -3860,11 +3839,6 @@ Proof \\ gvs [co_every_Fn_vs_NONE_shift_seq]) >- gvs [AppUnit_def, dec_clock_def, mglobals_disjoint_def, op_gbag_def] - >- ( - qpat_x_assum `evaluate (_,_,s0) = _` assume_tac - \\ drule evaluate_IMP_shift_seq \\ rw [] - \\ gvs [oracle_gapprox_disjoint_shift_seq, dec_clock_def, next_g_def]) - >- gvs [dec_clock_def, state_oracle_mglobals_disjoint_def] >- gvs [AppUnit_def] >- ( qpat_x_assum `evaluate (_,_,s0) = _` assume_tac @@ -3878,7 +3852,6 @@ Proof qpat_x_assum `evaluate (_,_,s0) = _` assume_tac \\ drule evaluate_IMP_shift_seq \\ rw [] \\ gvs [oracle_state_sgc_free_shift_seq]) - >- gvs [next_g_def] >- ( gvs [next_g_def, dec_clock_def] \\ qpat_x_assum `evaluate (_,_,s0) = _` assume_tac @@ -3897,7 +3870,6 @@ Proof \\ qmatch_asmsub_abbrev_tac `fv1 v' exp` \\ `fv v' [exp] ⇔ v' = 0` by (unabbrev_all_tac \\ gvs [fv_def]) \\ gvs []) - >- gvs [next_g_def] >- ( qpat_x_assum `evaluate (_,_,s0) = _` assume_tac \\ drule evaluate_IMP_shift_seq \\ rw [] diff --git a/compiler/backend/semantics/closPropsScript.sml b/compiler/backend/semantics/closPropsScript.sml index 461f346e47..d169abd71b 100644 --- a/compiler/backend/semantics/closPropsScript.sml +++ b/compiler/backend/semantics/closPropsScript.sml @@ -68,11 +68,11 @@ QED Theorem evaluate_better_ind: (∀xs s1. - (∀ys s2. s2.clock ≤ s1.clock ∧ (s2.clock = s1.clock ⇒ exp3_size ys < exp3_size xs) ⇒ P1 ys s2) ⇒ - (∀args s2. s2.clock ≤ s1.clock ∧ (s2.clock = s1.clock ⇒ LENGTH args < exp3_size xs) ⇒ P2 args s2) ⇒ + (∀ys s2. s2.clock ≤ s1.clock ∧ (s2.clock = s1.clock ⇒ exp3_alt_size ys < exp3_alt_size xs) ⇒ P1 ys s2) ⇒ + (∀args s2. s2.clock ≤ s1.clock ∧ (s2.clock = s1.clock ⇒ LENGTH args < exp3_alt_size xs) ⇒ P2 args s2) ⇒ P1 xs s1) ∧ (∀args s1. - (∀ys s2. s2.clock ≤ s1.clock ∧ (s2.clock = s1.clock ⇒ exp3_size ys < LENGTH args) ⇒ P1 ys s2) ⇒ + (∀ys s2. s2.clock ≤ s1.clock ∧ (s2.clock = s1.clock ⇒ exp3_alt_size ys < LENGTH args) ⇒ P1 ys s2) ⇒ (∀args' s2. s2.clock ≤ s1.clock ∧ (s2.clock = s1.clock ⇒ LENGTH args' < LENGTH args) ⇒ P2 args' s2) ⇒ P2 args s1) ⇒ (∀(xs:closLang$exp list) (s1:('c,'ffi) closSem$state). P1 xs s1) ∧ @@ -88,7 +88,7 @@ Proof \\ strip_tac \\ pop_assum mp_tac \\ qid_spec_tac ‘s1’ - \\ completeInduct_on ‘case x of INL xs => exp3_size xs | INR args => LENGTH args’ + \\ completeInduct_on ‘case x of INL xs => exp3_alt_size xs | INR args => LENGTH args’ \\ rw [] \\ gvs [forall_sum,SF DNF_ss, AND_IMP_INTRO, GSYM CONJ_ASSOC] \\ Cases_on ‘x’ \\ simp [] From ef9d3f25d45974b8799ce75e7c9991cf8b2d2dba Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 18 Sep 2025 23:33:16 +0300 Subject: [PATCH 094/112] Fixes for changes in closSemScript --- .../backend/proofs/clos_to_bvlProofScript.sml | 13 ++++--------- compiler/backend/semantics/bvlPropsScript.sml | 3 ++- compiler/backend/semantics/closPropsScript.sml | 18 ++++++++++++++++++ 3 files changed, 24 insertions(+), 10 deletions(-) diff --git a/compiler/backend/proofs/clos_to_bvlProofScript.sml b/compiler/backend/proofs/clos_to_bvlProofScript.sml index d3e4ddf53a..d845d776bc 100644 --- a/compiler/backend/proofs/clos_to_bvlProofScript.sml +++ b/compiler/backend/proofs/clos_to_bvlProofScript.sml @@ -4014,18 +4014,12 @@ Proof \\ Cases_on ‘thunk_mode’ \\ fs [] >- (gvs [] \\ first_x_assum $ irule_at $ Pos hd \\ fs []) \\ simp [bvlSemTheory.find_code_def] - \\ Cases_on ‘t2.clock = 0’ \\ fs [] - >- - (qexists_tac ‘0’ \\ gvs [] - \\ first_x_assum $ irule_at $ Pos hd \\ fs []) \\ drule bvlPropsTheory.evaluate_mono \\ simp [subspt_lookup] \\ disch_then drule \\ strip_tac \\ simp [dec_clock_def] \\ gvs [closSemTheory.dec_clock_def] \\ first_x_assum $ drule_at (Pat ‘state_rel _ _ _’) - \\ Cases_on - ‘evaluate ([AppUnit (Var None 0)],[v],r with clock := t2.clock − 1)’ - \\ gvs [] + \\ Cases_on ‘evaluate ([AppUnit (Var None 0)],[v],r)’ \\ gvs [] \\ Cases_on ‘q = Rerr (Rabort Rtype_error)’ \\ gvs [] \\ gvs [AppUnit_def] \\ simp [compile_exps_def] \\ disch_then $ qspecl_then [‘aux1’, ‘[r2]’] mp_tac \\ gvs [] @@ -4041,7 +4035,7 @@ Proof \\ gvs [domain_lookup]) >- gvs [env_rel_def]) \\ rw [] \\ gvs [] - \\ qexists ‘ck'’ \\ gvs [PULL_EXISTS] + \\ qexists ‘ck' + 1’ \\ gvs [PULL_EXISTS] \\ reverse $ Cases_on ‘q’ \\ gvs [PULL_EXISTS] >- ( goal_assum $ drule_at (Pat ‘state_rel _ _ _’) \\ gvs [] @@ -4054,7 +4048,8 @@ Proof find_code_def] \\ rpt (PURE_CASE_TAC \\ gvs []) \\ simp [force_thunk_code_def, evaluate_def, do_app_def, - find_code_def]) + find_code_def] + \\ rw [] \\ gvs []) \\ metis_tac [SUBMAP_TRANS]) \\ Cases_on ‘update_thunk [h] r'.refs a’ \\ gvs [PULL_EXISTS] \\ pop_assum mp_tac diff --git a/compiler/backend/semantics/bvlPropsScript.sml b/compiler/backend/semantics/bvlPropsScript.sml index da668c3cf4..3902a2b7ee 100644 --- a/compiler/backend/semantics/bvlPropsScript.sml +++ b/compiler/backend/semantics/bvlPropsScript.sml @@ -357,7 +357,8 @@ Proof \\ qexists_tac `n` \\ fs [dec_clock_def]) THEN1 (rw [] \\ gvs [AllCaseEqs(), NOT_LESS] - >~ [‘dest_thunk _ _ = IsThunk NotEvaluated _’, ‘find_code _ _ _ = SOME _’] + >~ [‘dest_thunk _ _ = IsThunk NotEvaluated _’, ‘find_code _ _ _ = SOME _’, + ‘s.clock ≠ 0’] >- (qexists ‘n'’ \\ gvs [shift_seq_def, dec_clock_def]) \\ qexists ‘0’ \\ gvs [shift_seq_def, FUN_EQ_THM]) \\ fs [case_eq_thms] \\ rw [] \\ fs [] diff --git a/compiler/backend/semantics/closPropsScript.sml b/compiler/backend/semantics/closPropsScript.sml index d169abd71b..008c60d4e5 100644 --- a/compiler/backend/semantics/closPropsScript.sml +++ b/compiler/backend/semantics/closPropsScript.sml @@ -1201,6 +1201,24 @@ Proof imp_res_tac dest_closure_full_length >> lfs[] QED +Theorem evaluate_app_clock0_timeout: + s0.clock = 0 ∧ args ≠ [] ∧ + evaluate_app lopt r args s0 = (Rerr e, s) ∧ + e ≠ Rabort Rtype_error ⇒ + e = Rabort Rtimeout_error +Proof + strip_tac >> `∃a1 args0. args = a1::args0` by (Cases_on `args` >> full_simp_tac(srw_ss())[]) >> + qpat_x_assum `evaluate_app _ _ _ _ = _` mp_tac >> + simp[evaluate_def] >> + Cases_on `dest_closure s0.max_app lopt r (a1::args0)` >> simp[] >> + rename1 `dest_closure s0.max_app lopt r (a1::args0) = SOME c` >> + Cases_on `c` >> simp[] >> + rename1 `dest_closure max_app lopt r (a1::args0) = SOME (Full_app b env rest)` >> + srw_tac[][] >> + `SUC (LENGTH args0) ≤ LENGTH rest` by simp[] >> + imp_res_tac dest_closure_full_length >> lfs[] +QED + Theorem evaluate_app_clock_drop: ∀args f lopt s0 s vs. evaluate_app lopt f args s0 = (Rval vs, s) ⇒ From fcbfbeb03e6109e13ddbfacb9340b6055d17bcd3 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Fri, 19 Sep 2025 00:19:18 +0300 Subject: [PATCH 095/112] Fixes for changes in bvlSemScript and bviSemScript --- compiler/backend/proofs/bvi_tailrecProofScript.sml | 10 +++++++++- compiler/backend/proofs/bvl_inlineProofScript.sml | 7 +++++-- compiler/backend/proofs/bvl_to_bviProofScript.sml | 6 +++++- compiler/backend/semantics/bviPropsScript.sml | 3 ++- 4 files changed, 21 insertions(+), 5 deletions(-) diff --git a/compiler/backend/proofs/bvi_tailrecProofScript.sml b/compiler/backend/proofs/bvi_tailrecProofScript.sml index 608ab8db84..68aa5db36e 100644 --- a/compiler/backend/proofs/bvi_tailrecProofScript.sml +++ b/compiler/backend/proofs/bvi_tailrecProofScript.sml @@ -1997,7 +1997,15 @@ Proof >- ( gvs [oneline dest_thunk_def, env_rel_def, AllCaseEqs(), PULL_EXISTS] \\ drule_then drule is_prefix_el \\ simp [] - \\ disch_then $ assume_tac o GSYM \\ gvs []) + \\ disch_then $ assume_tac o GSYM \\ gvs [] + \\ gvs [find_code_def, AllCaseEqs()] + \\ simp [GSYM PULL_EXISTS] \\ reverse $ rw [] + >- gvs [state_rel_def, state_component_equality] + \\ drule state_rel_code_rel \\ rw [code_rel_def] + \\ first_x_assum drule \\ rw [] + \\ gvs [compile_exp_def] + \\ Cases_on `check_exp force_loc 2 exp` \\ gvs [] + \\ pairarg_tac \\ gvs []) \\ last_assum $ qspecl_then [‘[exp]’, ‘dec_clock 1 s’] mp_tac \\ gvs [dec_clock_def] \\ disch_then drule diff --git a/compiler/backend/proofs/bvl_inlineProofScript.sml b/compiler/backend/proofs/bvl_inlineProofScript.sml index 864f189176..30f4020971 100644 --- a/compiler/backend/proofs/bvl_inlineProofScript.sml +++ b/compiler/backend/proofs/bvl_inlineProofScript.sml @@ -1007,7 +1007,9 @@ Proof THEN1 (gvs [AllCaseEqs(), evaluate_def, PULL_EXISTS, oneline dest_thunk_def] >- gvs [in_state_rel_def] - >- gvs [in_state_rel_def] + >- ( + gvs [in_state_rel_def, find_code_def, AllCaseEqs()] + \\ first_x_assum drule \\ rw [] \\ gvs []) \\ ‘in_state_rel limit (dec_clock 1 s) (dec_clock 1 t1)’ by gvs [in_state_rel_def, dec_clock_def] \\ last_x_assum drule \\ rw [] @@ -1592,7 +1594,8 @@ Proof THEN1 (gvs [AllCaseEqs(), PULL_EXISTS] >- gvs [let_state_rel_def] - >- gvs [let_state_rel_def] + >- gvs [let_state_rel_def, find_code_def, AllCaseEqs(), lookup_map, + let_opt_def] \\ rename1 ‘let_state_rel q l s t’ \\ ‘let_state_rel q l (dec_clock 1 s) (dec_clock 1 t)’ by gvs [let_state_rel_def, dec_clock_def] diff --git a/compiler/backend/proofs/bvl_to_bviProofScript.sml b/compiler/backend/proofs/bvl_to_bviProofScript.sml index f9a24c34c5..2e828c31a0 100644 --- a/compiler/backend/proofs/bvl_to_bviProofScript.sml +++ b/compiler/backend/proofs/bvl_to_bviProofScript.sml @@ -617,6 +617,7 @@ Proof >>~ [‘Force’] >- ( gvs [bvlSemTheory.evaluate_def, AllCaseEqs()] + >- gvs [state_ok_def] \\ last_x_assum mp_tac \\ impl_tac \\ rw [] >- gvs [state_ok_def, bvlSemTheory.dec_clock_def] \\ gvs [find_code_def, AllCaseEqs(), EVERY_EL, state_ok_def, @@ -3873,7 +3874,10 @@ Proof adjust_bv_def] \\ drule_all state_rel_FLOOKUP_Thunk \\ rw [] \\ gvs [] \\ goal_assum drule \\ gvs [inc_clock_def] - \\ qexistsl [‘t1’, ‘0’] \\ gvs [state_rel_def, state_component_equality]) + \\ qexistsl [‘t1’, ‘0’] \\ gvs [state_rel_def, state_component_equality] + \\ gvs [find_code_def, AllCaseEqs()] + \\ first_x_assum drule \\ rw [] \\ gvs [] + \\ pairarg_tac \\ gvs []) >- ( gvs [oneline bvlSemTheory.dest_thunk_def, oneline dest_thunk_def, AllCaseEqs()] diff --git a/compiler/backend/semantics/bviPropsScript.sml b/compiler/backend/semantics/bviPropsScript.sml index 9dab29b07a..a4608f27c4 100644 --- a/compiler/backend/semantics/bviPropsScript.sml +++ b/compiler/backend/semantics/bviPropsScript.sml @@ -425,7 +425,8 @@ Proof \\ qexists_tac`n` \\ fs[]) >- ( gvs [AllCaseEqs(), FUN_EQ_THM] - >~ [‘dest_thunk _ _ = IsThunk NotEvaluated _’, ‘find_code _ _ _ = SOME _’] + >~ [‘dest_thunk _ _ = IsThunk NotEvaluated _’, ‘find_code _ _ _ = SOME _’, + ‘s.clock ≠ 0’] >- (qexists ‘n'’ \\ gvs []) \\ qexists `0` \\ gvs []) QED From b4b12413014f40be54be90f7c1a5ae887bc3c6f6 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Fri, 19 Sep 2025 02:00:52 +0300 Subject: [PATCH 096/112] Fixes for changes in bviSemScript and dataSemScript --- .../backend/proofs/bvi_to_dataProofScript.sml | 25 +++++++++++--- .../backend/proofs/data_liveProofScript.sml | 11 +++--- .../backend/proofs/data_spaceProofScript.sml | 3 ++ .../backend/semantics/dataPropsScript.sml | 34 ++++++++++++------- 4 files changed, 51 insertions(+), 22 deletions(-) diff --git a/compiler/backend/proofs/bvi_to_dataProofScript.sml b/compiler/backend/proofs/bvi_to_dataProofScript.sml index 710ceafd9a..39b38edc6f 100644 --- a/compiler/backend/proofs/bvi_to_dataProofScript.sml +++ b/compiler/backend/proofs/bvi_to_dataProofScript.sml @@ -1437,19 +1437,36 @@ Proof >- gvs [jump_exc_def]) >- ( gvs [any_el_ALT, var_corr_def, LIST_REL_EL_EQN] - \\ last_x_assum $ drule_then assume_tac \\ gvs [] - \\ gvs [get_var_def, lookup_map] + \\ last_assum $ drule_then assume_tac \\ fs [] + \\ fs [get_var_def, lookup_map] \\ gvs [] \\ drule_all_then assume_tac state_rel_dest_thunk \\ gvs [] \\ `t1.clock = s.clock` by gvs [state_rel_def] \\ gvs [] - \\ gvs [state_rel_def, flush_state_def]) + \\ gvs [find_code_def, dataSemTheory.find_code_def, AllCaseEqs()] + \\ `lookup force_loc t1.code = SOME (2,compile_exp 2 exp)` + by gvs [state_rel_def, code_rel_def] \\ gvs [] + \\ Cases_on `tail` \\ gvs [] + >- gvs [state_rel_def] + \\ gvs [cut_env_def] + \\ `domain (list_to_num_set (live ++ corr)) ⊆ domain t1.locals` by ( + gvs [SUBSET_DEF, domain_lookup, lookup_list_to_num_set] + \\ rw [] + >- ( + gvs [EVERY_EL, MEM_EL] + \\ first_x_assum drule \\ rw [] + \\ Cases_on `lookup (EL n'' live) t1.locals` \\ gvs []) + >- ( + gvs [MEM_EL, state_rel_def] + \\ first_x_assum drule \\ rw [] + \\ simp [SF SFY_ss])) + \\ gvs [state_rel_def, call_env_def, push_env_def, dec_clock_def]) \\ gvs [any_el_ALT, var_corr_def, LIST_REL_EL_EQN] \\ first_assum $ drule_then assume_tac \\ fs [] \\ fs [get_var_def, lookup_map] \\ gvs [] \\ drule_all_then assume_tac state_rel_dest_thunk \\ gvs [] - \\ `t1.clock = s.clock` by gvs [state_rel_def] \\ gvs [] \\ `find_code (SOME force_loc) (MAP data_to_bvi_v [z;v']) s.code = SOME (args,exp)` by gvs [] \\ drule_all find_code_lemma \\ rw [] \\ gvs [] + \\ `t1.clock = s.clock` by gvs [state_rel_def] \\ gvs [] \\ Cases_on `tail` \\ gvs [PULL_EXISTS] >- ( gvs [compile_exp_def] diff --git a/compiler/backend/proofs/data_liveProofScript.sml b/compiler/backend/proofs/data_liveProofScript.sml index 3759177c14..b026e28c5b 100644 --- a/compiler/backend/proofs/data_liveProofScript.sml +++ b/compiler/backend/proofs/data_liveProofScript.sml @@ -334,13 +334,13 @@ Proof >- gvs [state_rel_def, flush_state_def] \\ ‘t1.code = s.code ∧ t1.stack_frame_sizes = s.stack_frame_sizes’ by gvs [state_rel_def] \\ gvs [] - \\ ‘t1.clock = s.clock’ by gvs [state_rel_def] \\ gvs [] - \\ Cases_on ‘s.clock = 0’ \\ gvs [] - >- gvs [state_rel_def, flush_state_def] \\ Cases_on ‘find_code (SOME loc) [x; v] s.code s.stack_frame_sizes’ \\ gvs [] \\ Cases_on ‘x'’ \\ gvs [] \\ Cases_on ‘r’ \\ gvs [] + \\ ‘t1.clock = s.clock’ by gvs [state_rel_def] \\ gvs [] + \\ Cases_on ‘s.clock = 0’ \\ gvs [] + >- gvs [state_rel_def, flush_state_def] \\ Cases_on ‘evaluate (q',call_env q r' (dec_clock s))’ \\ gvs [] \\ Cases_on ‘q''’ \\ gvs [] \\ fs [] @@ -416,8 +416,6 @@ Proof \\ ‘t1.code = s.code ∧ t1.stack_frame_sizes = s.stack_frame_sizes ∧ t1.clock = s.clock’ by gvs [state_rel_def] \\ gvs [] - \\ Cases_on ‘s.clock = 0’ \\ gvs [] - >- gvs [state_rel_def, flush_state_def] \\ Cases_on ‘find_code (SOME loc) [x; v'] s.code s.stack_frame_sizes’ \\ gvs [] \\ Cases_on ‘x'’ \\ gvs [] @@ -430,6 +428,9 @@ Proof domain_delete,state_rel_def] \\ rpt strip_tac \\ imp_res_tac get_vars_IMP_domain \\ fs [domain_lookup] \\ metis_tac []) + \\ Cases_on ‘s.clock = 0’ \\ gvs [] + >- gvs [state_rel_def, call_env_def, push_env_def, dec_clock_def, + flush_state_def] \\ qabbrev_tac `t5 = call_env q r' (push_env ((inter t1.locals (inter names (delete v l2)))) F (dec_clock t1))` \\ `?sfsp smax lss. (call_env q r' (push_env ((inter s.locals names)) F diff --git a/compiler/backend/proofs/data_spaceProofScript.sml b/compiler/backend/proofs/data_spaceProofScript.sml index a73f912f82..a245057d51 100644 --- a/compiler/backend/proofs/data_spaceProofScript.sml +++ b/compiler/backend/proofs/data_spaceProofScript.sml @@ -469,6 +469,9 @@ Proof gvs [PULL_EXISTS] \\ gvs [call_env_def, dec_clock_def, push_env_def, locals_ok_def] \\ gvs [state_component_equality]) + >- ( + gvs [call_env_def, push_env_def, dec_clock_def, state_component_equality] + \\ metis_tac [locals_ok_refl]) >- ( gvs [call_env_def, push_env_def, dec_clock_def, state_component_equality] \\ metis_tac [locals_ok_refl])) diff --git a/compiler/backend/semantics/dataPropsScript.sml b/compiler/backend/semantics/dataPropsScript.sml index 15fa4cf16c..058ffae967 100644 --- a/compiler/backend/semantics/dataPropsScript.sml +++ b/compiler/backend/semantics/dataPropsScript.sml @@ -1063,6 +1063,7 @@ Proof \\ disch_then $ qspecl_then [‘smnew’,‘ssnew’,‘s.peak_heap_length’] mp_tac \\ rw [] \\ gvs [] \\ simp [state_component_equality]) + >- gvs [call_env_def, push_env_def, dec_clock_def, state_component_equality] >- ( rw [] >- gvs [call_env_def, push_env_def, dec_clock_def, pop_env_def, @@ -1670,15 +1671,15 @@ Proof \\ imp_res_tac locals_ok_cut_env \\ gvs [] \\ gvs [state_component_equality, locals_ok_def]) \\ imp_res_tac locals_ok_get_var \\ gvs [] - \\ Cases_on ‘s.clock = 0’ \\ gvs [] - >- gvs [flush_state_def, state_component_equality, locals_ok_def] \\ Cases_on ‘find_code (SOME loc) [x; v] s.code s.stack_frame_sizes’ \\ gvs [] \\ Cases_on ‘x'’ \\ gvs [] \\ Cases_on ‘r’ \\ gvs [] \\ Cases_on ‘ret’ \\ gvs [] >- ( - ‘call_env q r' (dec_clock (s with locals := l)) = + IF_CASES_TAC \\ gvs [] + >- (simp [state_component_equality] \\ metis_tac [locals_ok_refl]) + \\ ‘call_env q r' (dec_clock (s with locals := l)) = call_env q r' (dec_clock s)’ by fs[state_component_equality, dec_clock_def, call_env_def, flush_state_def] @@ -2323,8 +2324,6 @@ Proof \\ Cases_on ‘x'’ \\ gvs [] \\ Cases_on ‘cut_env r' s.locals’ \\ gvs [] \\ gvs [set_var_def, state_component_equality]) - \\ Cases_on ‘s.clock = 0’ \\ gvs [] - >- gvs [flush_state_def, state_component_equality] \\ Cases_on ‘find_code (SOME loc) [x; v] s.code s.stack_frame_sizes’ \\ gvs [] >- gvs [state_component_equality] @@ -2332,7 +2331,9 @@ Proof \\ Cases_on ‘r'’ \\ gvs [] \\ Cases_on ‘ret’ \\ gvs [] >- ( - gvs [dec_clock_def] + IF_CASES_TAC \\ gvs [] + >- simp [state_component_equality] + \\ gvs [dec_clock_def] \\ Cases_on ‘evaluate (q',call_env q r'' (s with clock := s.clock − 1))’ \\ gvs [call_env_def] \\ Cases_on ‘q''’ \\ gvs [] @@ -2346,6 +2347,8 @@ Proof \\ Cases_on ‘x'’ \\ gvs [] \\ Cases_on ‘cut_env r' s.locals’ \\ gvs [] >- gvs [state_component_equality] + \\ IF_CASES_TAC \\ gvs [] + >- gvs [state_component_equality, call_env_def, push_env_def, dec_clock_def] \\ gvs [push_env_def, call_env_def, dec_clock_def] \\ gvs [AllCaseEqs(), PULL_EXISTS] \\ qmatch_goalsub_abbrev_tac ‘stack_max_fupd (K smnew)’ @@ -2546,8 +2549,6 @@ Proof \\ Cases_on ‘x'’ \\ gvs [] \\ Cases_on ‘cut_env r' s.locals’ \\ gvs [] \\ gvs [set_var_def, state_component_equality]) - \\ Cases_on ‘s.clock = 0’ \\ gvs [] - >- gvs [flush_state_def, state_component_equality] \\ Cases_on ‘find_code (SOME loc) [x; v] s.code s.stack_frame_sizes’ \\ gvs [] >- ( @@ -2558,7 +2559,9 @@ Proof \\ Cases_on ‘r'’ \\ gvs [] \\ Cases_on ‘ret’ \\ gvs [] >- ( - gvs [dec_clock_def] + IF_CASES_TAC \\ gvs [] + >- simp [state_component_equality] + \\ gvs [dec_clock_def] \\ Cases_on ‘evaluate (q',call_env q r'' (s with clock := s.clock − 1))’ \\ gvs [call_env_def] \\ Cases_on ‘q''’ \\ gvs [] @@ -2573,6 +2576,8 @@ Proof \\ Cases_on ‘x'’ \\ gvs [] \\ Cases_on ‘cut_env r' s.locals’ \\ gvs [] >- gvs [state_component_equality] + \\ IF_CASES_TAC \\ gvs [] + >- gvs [state_component_equality, call_env_def, push_env_def, dec_clock_def] \\ gvs [push_env_def, call_env_def, dec_clock_def] \\ fs [AllCaseEqs(), PULL_EXISTS] \\ rveq \\ qmatch_goalsub_abbrev_tac ‘stack_max_fupd (K smnew)’ @@ -3064,16 +3069,19 @@ Proof >- ( gvs [AllCaseEqs(), PULL_EXISTS, flush_state_def] \\ gvs [cc_co_only_diff_def,state_component_equality,set_var_def]) - \\ TOP_CASE_TAC \\ gvs [] - >- gvs [cc_co_only_diff_def, flush_state_def] \\ gvs [CaseEq "prod"] \\ ntac 4 (TOP_CASE_TAC \\ gvs []) >- ( - gvs [AllCaseEqs(), PULL_EXISTS, flush_state_def] + IF_CASES_TAC \\ gvs [] + >- simp [cc_co_only_diff_def] + \\ gvs [AllCaseEqs(), PULL_EXISTS, flush_state_def] \\ first_x_assum (qspec_then ‘call_env q r' (dec_clock t)’ mp_tac) \\ gvs [cc_co_only_diff_def, call_env_def, dec_clock_def] \\ rw [] \\ gvs []) - \\ ntac 3 (TOP_CASE_TAC \\ gvs []) + \\ ntac 2 (TOP_CASE_TAC \\ gvs []) + \\ IF_CASES_TAC \\ gvs [] + >- gvs [cc_co_only_diff_def, call_env_def, push_env_def, dec_clock_def] + \\ TOP_CASE_TAC \\ gvs [] \\ gvs [CaseEq"prod"] \\ drule_then (qspecl_then [‘x'’,‘r'’,‘F’,‘q’] strip_assume_tac) cc_co_only_diff_call_env From 972a28dd12a34ed4fda50a00210e84261f7c9487 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Fri, 19 Sep 2025 14:29:12 +0300 Subject: [PATCH 097/112] Progress on `data_to_wordProof` --- .../proofs/data_to_wordProofScript.sml | 211 +++++++++--------- 1 file changed, 111 insertions(+), 100 deletions(-) diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml index 7fb199692b..eefaf6da7a 100644 --- a/compiler/backend/proofs/data_to_wordProofScript.sml +++ b/compiler/backend/proofs/data_to_wordProofScript.sml @@ -248,142 +248,153 @@ Proof \\ fs [cut_state_def,cut_env_def] \\ every_case_tac \\ fs [] \\ rw [] \\ fs [set_var_def]) >~ [‘evaluate (Force _ _ _,s)’] >- - (gvs [evaluate_def] - \\ Cases_on `get_var src s.locals` \\ gvs [] - \\ Cases_on `dest_thunk x s.refs` \\ gvs [] - \\ simp [comp_def, force_thunk_def] + (simp [comp_def, force_thunk_def] \\ TOP_CASE_TAC \\ gvs [] - >- ( - fs[encode_header_def] - \\ fs[encode_header_def, state_rel_def, good_dimindex_def, limits_inv_def, - dimword_def, memory_rel_def, heap_in_memory_store_def, - consume_space_def, arch_size_def] - \\ rfs[NOT_LESS]) + >- gvs [encode_header_def, encode_header_def, state_rel_def, + good_dimindex_def, limits_inv_def, dimword_def, memory_rel_def, + heap_in_memory_store_def, consume_space_def, arch_size_def, + NOT_LESS] \\ simp [wordSemTheory.evaluate_def] - \\ `∃v0 ptr. get_var src s.locals = SOME (RefPtr v0 ptr)` - by gvs [oneline dest_thunk_def, AllCaseEqs()] + \\ gvs [evaluate_def] + \\ Cases_on `get_var src s.locals` \\ gvs [] + \\ Cases_on `dest_thunk x' s.refs` \\ gvs [] + \\ gvs [oneline dest_thunk_def] + \\ Cases_on `x'` \\ gvs [] + \\ Cases_on `lookup n' s.refs` \\ gvs [] + \\ Cases_on `x'` \\ gvs [] + \\ `IsThunk t' v = IsThunk t'' a` by (Cases_on `t''` \\ gvs []) \\ gvs [] + \\ qpat_x_assum `_ = IsThunk t' a` kall_tac \\ drule_all state_rel_get_var_RefPtr \\ rw [] \\ gvs [] \\ simp [wordSemTheory.get_var_imm_def, word_cmp_Test_1, word_bit_def, get_addr_0] - \\ simp [list_Seq_def, wordSemTheory.evaluate_def] - \\ gvs [dest_thunk_def] - \\ Cases_on `lookup ptr s.refs` \\ gvs [] - \\ Cases_on `x` \\ gvs [] + \\ simp [Once list_Seq_def, wordSemTheory.evaluate_def] \\ qpat_assum `state_rel _ _ _ _ _ _ _` mp_tac - \\ pure_rewrite_tac [state_rel_thm] \\ rw [] + \\ pure_rewrite_tac [Once state_rel_thm] \\ rw [] \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] \\ drule_all memory_rel_get_var_IMP \\ rw [] \\ gvs [] \\ drule_all memory_rel_Force \\ rw [] \\ gvs [] - \\ drule_all memory_rel_Thunk_bits \\ strip_tac - \\ `word_exp t (real_addr c (adjust_var src)) = SOME (Word x)` + \\ `word_exp t (real_addr c (adjust_var src)) = SOME (Word x')` by metis_tac [get_real_addr_lemma] \\ gvs [] + \\ simp [Once list_Seq_def, wordSemTheory.evaluate_def] \\ simp [wordSemTheory.set_var_def, wordSemTheory.word_exp_def, - wordSemTheory.get_var_def, wordSemTheory.mem_load_def, - wordSemTheory.the_words_def, word_op_def, lookup_insert] - \\ simp [wordSemTheory.get_var_imm_def] - \\ Cases_on `t''` \\ gvs [] + wordSemTheory.get_var_def, wordSemTheory.the_words_def, + wordSemTheory.mem_load_def, word_op_def] + \\ simp [list_Seq_def, wordSemTheory.evaluate_def] + \\ simp [wordSemTheory.get_var_def, wordSemTheory.get_var_imm_def] + \\ drule_all memory_rel_Thunk_bits \\ strip_tac + \\ Cases_on `t'` \\ gvs [] >- ( simp [asmTheory.word_cmp_def] \\ Cases_on `ret` \\ gvs [] >- ( simp [wordSemTheory.evaluate_def] \\ simp [wordSemTheory.word_exp_def, wordSemTheory.get_var_def, - lookup_insert, wordSemTheory.the_words_def, word_op_def, - wordSemTheory.mem_load_def, wordSemTheory.get_vars_def, - wordSemTheory.set_var_def] + lookup_insert, wordSemTheory.the_words_def, + word_op_def, wordSemTheory.mem_load_def, + wordSemTheory.set_var_def, wordSemTheory.get_vars_def] \\ simp [flush_state_def, wordSemTheory.flush_state_def] - \\ conj_tac - >- (imp_res_tac option_le_add_indv) - \\ simp [join_env_def] - \\ first_x_assum (fn th => - mp_tac th THEN match_mp_tac memory_rel_rearrange) - \\ rw [] \\ gvs []) + \\ cheat) \\ Cases_on `x''` \\ gvs [] - \\ simp [wordSemTheory.evaluate_def] - \\ simp [wordSemTheory.word_exp_def, wordSemTheory.get_var_def, - lookup_insert, wordSemTheory.the_words_def, word_op_def, - wordSemTheory.mem_load_def, wordSemTheory.set_var_def] + \\ simp [wordSemTheory.evaluate_def, wordSemTheory.word_exp_def, + wordSemTheory.get_var_def, lookup_insert, + wordSemTheory.the_words_def, word_op_def, + wordSemTheory.mem_load_def] \\ Cases_on `cut_env r s.locals` \\ gvs [] - \\ simp [set_var_def] - \\ drule_all state_rel_cut_env \\ rw [] - >- ( - IF_CASES_TAC \\ gvs [] - \\ gvs [state_rel_thm, lookup_insert, adjust_var_11]) - \\ gvs [inter_insert_ODD_adjust_set] - \\ pure_rewrite_tac [GSYM APPEND_ASSOC] - \\ irule memory_rel_insert \\ gvs [] - \\ gvs [state_rel_thm] - \\ first_x_assum (fn th => - mp_tac th THEN match_mp_tac memory_rel_rearrange) - \\ rw [] \\ gvs [] + \\ simp [wordSemTheory.set_var_def, set_var_def] + \\ `state_rel c l1 l2 + (s with locals := insert q a x'') + (t with locals := insert (adjust_var q) + (t.memory (x' + bytes_in_word)) t.locals) + [] locs` suffices_by ( + rw [] \\ gvs [] + \\ gvs [state_rel_def, lookup_insert] + \\ asm_exists_tac \\ gvs [] + \\ gvs [inter_insert, domain_lookup, lookup_1_adjust_set, + lookup_3_adjust_set]) \\ cheat) - \\ `¬word_cmp Equal 24w 56w` by ( - simp [asmTheory.word_cmp_def, dimword_def] \\ fs [good_dimindex_def]) - \\ gvs [] - \\ simp [asmTheory.word_cmp_def] - \\ simp [wordSemTheory.get_vars_def, wordSemTheory.get_var_def, - lookup_insert] - \\ simp [GSYM wordSemTheory.get_var_def] - \\ simp [wordSemTheory.bad_dest_args_def] - \\ Cases_on `s.clock = 0` \\ gvs [] >- ( - TOP_CASE_TAC \\ simp [wordSemTheory.evaluate_def] - >- ( - simp [wordSemTheory.get_vars_def, wordSemTheory.get_var_def, - lookup_insert] - \\ simp [GSYM wordSemTheory.get_var_def] - \\ simp [wordSemTheory.bad_dest_args_def] - \\ cheat) - \\ TOP_CASE_TAC \\ simp [wordSemTheory.evaluate_def] - \\ simp [wordSemTheory.get_vars_def, wordSemTheory.get_var_def, - lookup_insert] - \\ simp [GSYM wordSemTheory.get_var_def] - \\ simp [wordSemTheory.bad_dest_args_def] - \\ cheat) - \\ Cases_on `find_code (SOME loc) [RefPtr v0 ptr; a] s.code + \\ IF_CASES_TAC \\ gvs [] + >- gvs [asmTheory.word_cmp_def, dimword_def, good_dimindex_def] + \\ IF_CASES_TAC \\ gvs [] + >- gvs [asmTheory.word_cmp_def, dimword_def, good_dimindex_def] + \\ simp [wordSemTheory.word_exp_def, wordSemTheory.get_var_def, + lookup_insert, wordSemTheory.the_words_def, word_op_def, + wordSemTheory.mem_load_def, wordSemTheory.set_var_def] + \\ Cases_on `find_code (SOME loc) [RefPtr b n'; a] s.code s.stack_frame_sizes` \\ gvs [] \\ Cases_on `x''` \\ gvs [] \\ Cases_on `r` \\ gvs [] \\ Cases_on `ret` \\ gvs [] >- ( - Cases_on `evaluate (q',call_env q r' (dec_clock s))` \\ gvs [] - \\ Cases_on `q''` \\ gvs [] - \\ simp [wordSemTheory.evaluate_def, wordSemTheory.get_vars_def, - wordSemTheory.get_var_def, lookup_insert] - \\ gvs [wordSemTheory.get_var_def] - \\ simp [wordSemTheory.bad_dest_args_def, wordSemTheory.add_ret_loc_def] + simp [wordSemTheory.evaluate_def, wordSemTheory.get_vars_def, + wordSemTheory.get_var_def, lookup_insert] + \\ once_rewrite_tac [GSYM wordSemTheory.get_var_def] \\ gvs [] + \\ simp [wordSemTheory.bad_dest_args_def] \\ gvs [find_code_def] \\ Cases_on `lookup loc s.code` \\ gvs [] - \\ Cases_on `x'''` \\ gvs [] + \\ Cases_on `x''` \\ gvs [] \\ simp [wordSemTheory.find_code_def] + \\ qpat_x_assum `code_rel _ _ _` assume_tac \\ gvs [code_rel_def] - \\ first_x_assum $ drule_at (Pat `lookup _ s.code = _`) \\ rw [] - \\ gvs [GSYM wordSemTheory.get_var_def] - \\ `state_rel c l1 l2 s - (t with locals := insert 5 (t.memory (x + bytes_in_word)) - (insert 3 (Word 24w) - (insert 1 (Word x) t.locals))) [] locs` by ( - fs [state_rel_def] \\ srw_tac[][] - \\ fs [lookup_insert,adjust_var_NEQ_1] - \\ asm_exists_tac \\ fs [] - \\ fs [inter_insert,domain_lookup, - lookup_3_adjust_set,lookup_1_adjust_set,lookup_5_adjust_set]) - \\ drule_at (Pat `state_rel _ _ _ _ _ _ _`) state_rel_call_env_get_var - \\ disch_then drule - \\ simp [wordSemTheory.get_var_def, lookup_insert] - \\ simp [GSYM wordSemTheory.get_var_def] + \\ first_x_assum drule \\ strip_tac \\ gvs [] + \\ simp [wordSemTheory.add_ret_loc_def] + \\ IF_CASES_TAC \\ gvs [] + >- simp [wordSemTheory.flush_state_def] + \\ Cases_on + `evaluate (q', call_env [RefPtr b n'; a] + (lookup loc s.stack_frame_sizes) + (dec_clock s))` \\ gvs [] + \\ Cases_on `q` \\ gvs [] + \\ drule_all state_rel_call_env_get_var \\ disch_then - $ qspecl_then [`(x + bytes_in_word)`, `lookup loc s.stack_frame_sizes`, `a`] - assume_tac \\ gvs [] - \\ last_x_assum drule \\ simp [call_env_def] + $ qspecl_then [`x' + bytes_in_word`, `lookup loc s.stack_frame_sizes`, + `a`] assume_tac \\ gvs [] + \\ last_x_assum drule \\ simp [] \\ disch_then $ qspecl_then [`loc`, `2`] assume_tac \\ gvs [] + \\ gvs [wordSemTheory.dec_clock_def] \\ Cases_on `res1` \\ gvs [] \\ Cases_on `x'''` \\ gvs [] - >- ( - Cases_on `x''` \\ gvs [] - \\ gvs [state_rel_thm, wordSemTheory.get_var_def, code_rel_def]) \\ Cases_on `x''` \\ gvs [] \\ Cases_on `e` \\ gvs [] - \\ cheat) + \\ gvs [wordSemTheory.call_env_def, wordSemTheory.jump_exc_def] + \\ IF_CASES_TAC \\ gvs [] + \\ ntac 5 (TOP_CASE_TAC \\ gvs []) + \\ simp [mk_loc_def] + \\ simp [GSYM wordSemTheory.set_var_def]) + \\ Cases_on `x''` \\ gvs [] + \\ simp [wordSemTheory.evaluate_def, wordSemTheory.get_vars_def, + wordSemTheory.get_var_def, lookup_insert] + \\ once_rewrite_tac [GSYM wordSemTheory.get_var_def] \\ gvs [] + \\ simp [wordSemTheory.bad_dest_args_def] + \\ gvs [find_code_def] + \\ Cases_on `lookup loc s.code` \\ gvs [] + \\ Cases_on `x''` \\ gvs [] + \\ simp [wordSemTheory.find_code_def] + \\ qpat_x_assum `code_rel _ _ _` assume_tac + \\ gvs [code_rel_def] + \\ first_x_assum drule \\ strip_tac \\ gvs [] + \\ simp [wordSemTheory.add_ret_loc_def, domain_adjust_sets] + \\ Cases_on `cut_env r s.locals` \\ gvs [] + \\ simp [cut_envs_adjust_sets_insert_ODD] + \\ pop_assum mp_tac + \\ simp [cut_env_def, SUBSET_DEF, domain_lookup] \\ strip_tac \\ gvs [] + \\ simp [adjust_sets_def, adjust_set_def, wordSemTheory.cut_envs_def, + wordSemTheory.cut_names_def, domain_lookup, domain_fromAList] + \\ simp [SUBSET_DEF, MEM_MAP, PULL_EXISTS] + \\ reverse $ IF_CASES_TAC \\ gvs [] + >- ( + spose_not_then kall_tac + \\ pairarg_tac \\ gvs [MEM_toAList, domain_lookup] + \\ first_x_assum $ drule_then assume_tac \\ gvs [] + \\ first_x_assum $ qspec_then `n` assume_tac \\ gvs [] + \\ Cases_on `lookup (adjust_var n) t.locals` \\ gvs []) + \\ IF_CASES_TAC \\ gvs [] + >- cheat + \\ Cases_on + `evaluate (q', call_env [RefPtr b n'; a] + (lookup loc s.stack_frame_sizes) + (push_env (inter s.locals r) F (dec_clock s)))` + \\ gvs [] + \\ Cases_on `q` \\ gvs [] \\ cheat) >~ [‘evaluate (Tick,s)’] >- (fs [comp_def,dataSemTheory.evaluate_def,wordSemTheory.evaluate_def] From 5c063280505413d42f947997dea16734bf84232e Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 25 Sep 2025 02:01:44 +0300 Subject: [PATCH 098/112] Update for change in name of while theory --- basis/fsFFIPropsScript.sml | 2 +- basis/pure/mlstringScript.sml | 4 +-- .../syntax/holSyntaxExtraScript.sml | 2 +- candle/overloading/syntax/holSyntaxScript.sml | 2 +- candle/standard/syntax/holSyntaxScript.sml | 2 +- characteristic/cfDivScript.sml | 4 +-- compiler/backend/ag32/ag32_memoryScript.sml | 32 +++++++++---------- .../ag32/proofs/ag32_basis_ffiProofScript.sml | 6 ++-- .../ag32/proofs/ag32_ffi_codeProofScript.sml | 8 ++--- .../backend/proofs/bvl_to_bviProofScript.sml | 18 +++++------ .../backend/proofs/clos_to_bvlProofScript.sml | 4 +-- .../proofs/data_to_wordProofScript.sml | 2 +- .../proofs/data_to_word_assignProofScript.sml | 2 +- .../proofs/data_to_word_gcProofScript.sml | 2 +- .../proofs/data_to_word_memoryProofScript.sml | 2 +- .../proofs/flat_to_closProofScript.sml | 2 +- .../proofs/lab_to_targetProofScript.sml | 2 +- .../backend/proofs/source_evalProofScript.sml | 10 +++--- compiler/backend/reg_alloc/parmoveScript.sml | 6 ++-- compiler/inference/unifyScript.sml | 24 +++++++------- examples/filterProgScript.sml | 4 +-- misc/miscScript.sml | 4 +-- pancake/semantics/panItreeSemScript.sml | 2 +- translator/std_preludeScript.sml | 2 +- 24 files changed, 74 insertions(+), 74 deletions(-) diff --git a/basis/fsFFIPropsScript.sml b/basis/fsFFIPropsScript.sml index ff83e0285b..aa23fcc1a7 100644 --- a/basis/fsFFIPropsScript.sml +++ b/basis/fsFFIPropsScript.sml @@ -150,7 +150,7 @@ Proof fs [validFD_def,nextFD_def] \\ qabbrev_tac `xs = MAP FST fs.infds` \\ match_mp_tac (SIMP_RULE std_ss [] - (Q.ISPEC `\n:num. ~MEM n xs` whileTheory.LEAST_INTRO)) + (Q.ISPEC `\n:num. ~MEM n xs` WhileTheory.LEAST_INTRO)) \\ qexists_tac `SUM xs + 1` \\ strip_tac \\ qsuff_tac `!xs m:num. MEM m xs ==> m <= SUM xs` diff --git a/basis/pure/mlstringScript.sml b/basis/pure/mlstringScript.sml index 17a2f2d5e8..4910d25f84 100644 --- a/basis/pure/mlstringScript.sml +++ b/basis/pure/mlstringScript.sml @@ -749,10 +749,10 @@ Theorem OLEAST_LE_STEP: else (OLEAST j. i + 1 <= j /\ P j)) Proof rw [] - \\ simp [whileTheory.OLEAST_EQ_SOME] + \\ simp [WhileTheory.OLEAST_EQ_SOME] \\ qmatch_goalsub_abbrev_tac `opt1 = $OLEAST _` \\ Cases_on `opt1` - \\ fs [whileTheory.OLEAST_EQ_SOME] + \\ fs [WhileTheory.OLEAST_EQ_SOME] \\ rw [] \\ fs [LESS_EQ |> REWRITE_RULE [ADD1] |> GSYM, arithmeticTheory.LT_LE] \\ CCONTR_TAC diff --git a/candle/overloading/syntax/holSyntaxExtraScript.sml b/candle/overloading/syntax/holSyntaxExtraScript.sml index 3d23e03072..ebd32aeffd 100644 --- a/candle/overloading/syntax/holSyntaxExtraScript.sml +++ b/candle/overloading/syntax/holSyntaxExtraScript.sml @@ -12996,7 +12996,7 @@ Proof rw[] >> last_x_assum(qspec_then `f` mp_tac) >> disch_then assume_tac >> - pop_assum(mp_tac o Ho_Rewrite.REWRITE_RULE[whileTheory.LEAST_EXISTS]) >> + pop_assum(mp_tac o Ho_Rewrite.REWRITE_RULE[WhileTheory.LEAST_EXISTS]) >> rename1 `f n` >> rpt strip_tac >> reverse(Cases_on `R' (f n) (f (SUC n))`) >- goal_assum drule >> diff --git a/candle/overloading/syntax/holSyntaxScript.sml b/candle/overloading/syntax/holSyntaxScript.sml index 6782da328f..3cf4d8d524 100644 --- a/candle/overloading/syntax/holSyntaxScript.sml +++ b/candle/overloading/syntax/holSyntaxScript.sml @@ -298,7 +298,7 @@ QED Theorem LEAST_EXISTS[local]: (∃n:num. P n) ⇒ ∃k. P k ∧ ∀m. m < k ⇒ ¬(P m) Proof - metis_tac[whileTheory.LEAST_EXISTS] + metis_tac[WhileTheory.LEAST_EXISTS] QED val VARIANT_PRIMES_def = new_specification diff --git a/candle/standard/syntax/holSyntaxScript.sml b/candle/standard/syntax/holSyntaxScript.sml index 2974f4f49a..f6dfb9bcf2 100644 --- a/candle/standard/syntax/holSyntaxScript.sml +++ b/candle/standard/syntax/holSyntaxScript.sml @@ -271,7 +271,7 @@ QED Triviality LEAST_EXISTS: (∃n:num. P n) ⇒ ∃k. P k ∧ ∀m. m < k ⇒ ¬(P m) Proof - metis_tac[whileTheory.LEAST_EXISTS] + metis_tac[WhileTheory.LEAST_EXISTS] QED val VARIANT_PRIMES_def = new_specification diff --git a/characteristic/cfDivScript.sml b/characteristic/cfDivScript.sml index cfd59a49c0..8c41138d93 100644 --- a/characteristic/cfDivScript.sml +++ b/characteristic/cfDivScript.sml @@ -4420,7 +4420,7 @@ Proof \\ rw[] \\ `LFLATTEN(LGENLIST f NONE) <> [||]` by(CCONTR_TAC >> fs[]) \\ dxrule LFLATTEN_NOT_NIL_IMP - \\ disch_then(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[whileTheory.LEAST_EXISTS]) + \\ disch_then(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[WhileTheory.LEAST_EXISTS]) \\ qmatch_asmsub_abbrev_tac `LNTH a1` \\ Q.ISPECL_THEN [`a1`,`f`] assume_tac (GEN_ALL LGENLIST_CHUNK_GENLIST) \\ fs[] @@ -4720,7 +4720,7 @@ Proof (fs[Once LFLATTEN]) \\ match_mp_tac OR_INTRO_THM2 \\ pop_assum(assume_tac o Ho_Rewrite.REWRITE_RULE [every_LGENLIST,o_DEF,NOT_FORALL_THM]) - \\ pop_assum(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[whileTheory.LEAST_EXISTS]) + \\ pop_assum(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[WhileTheory.LEAST_EXISTS]) \\ fs[CONV_RULE(LHS_CONV SYM_CONV) fromList_EQ_LNIL] \\ qspecl_then [`LEAST x. events (n + x) <> []`,`fromList o events o $+ n`] mp_tac (LGENLIST_CHUNK_GENLIST diff --git a/compiler/backend/ag32/ag32_memoryScript.sml b/compiler/backend/ag32/ag32_memoryScript.sml index f559759f99..8382b62b87 100644 --- a/compiler/backend/ag32/ag32_memoryScript.sml +++ b/compiler/backend/ag32/ag32_memoryScript.sml @@ -876,7 +876,7 @@ Theorem ag32_ffi_get_arg_length_loop1_thm: ((4w =+ s.R 4w + n2w (n+1)) ((5w =+ s.R 5w + n2w (n+1)) s.R))) |> Proof - reverse(rw[whileTheory.OLEAST_def]) + reverse(rw[WhileTheory.OLEAST_def]) >- ( rw[Once ag32_ffi_get_arg_length_loop1_def] \\ fs[] \\ metis_tac[] ) @@ -987,7 +987,7 @@ Proof \\ simp[Once get_next_mem_arg_def] \\ Cases_on`m a = 0w` \\ fs[] >- ( - simp[whileTheory.OLEAST_def] + simp[WhileTheory.OLEAST_def] \\ IF_CASES_TAC \\ fs[] \\ numLib.LEAST_ELIM_TAC \\ conj_tac >- metis_tac[] @@ -996,9 +996,9 @@ Proof \\ first_x_assum(qspec_then`0`mp_tac) \\ simp[] ) \\ IF_CASES_TAC - >- ( simp[whileTheory.OLEAST_def] ) + >- ( simp[WhileTheory.OLEAST_def] ) \\ fs[] - \\ simp[whileTheory.OLEAST_def] + \\ simp[WhileTheory.OLEAST_def] \\ reverse IF_CASES_TAC \\ fs[] >- ( Cases_on`n` \\ fs[] @@ -1053,7 +1053,7 @@ Proof ag32Theory.dfn'JumpIfNotZero_def, ag32_ffi_get_arg_length_loop1_thm, APPLY_UPDATE_THM] \\ CASE_TAC \\ simp[APPLY_UPDATE_THM] - \\ fs[whileTheory.OLEAST_def] + \\ fs[WhileTheory.OLEAST_def] \\ simp[Once ag32_ffi_get_arg_length_loop_def, APPLY_UPDATE_THM] \\ simp[ag32Theory.dfn'JumpIfZero_def, ag32Theory.incPC_def, ag32Theory.ri2word_def, ag32Theory.ALU_def, APPLY_UPDATE_THM] @@ -1068,7 +1068,7 @@ Proof \\ rw[] \\ fs[] \\ AP_THM_TAC \\ AP_TERM_TAC \\ AP_THM_TAC \\ AP_TERM_TAC - \\ simp[get_next_mem_arg_LEAST, whileTheory.OLEAST_def] + \\ simp[get_next_mem_arg_LEAST, WhileTheory.OLEAST_def] \\ IF_CASES_TAC \\ fs[]) \\ rw[] \\ simp[Once ag32_ffi_get_arg_length_loop_def] @@ -1078,7 +1078,7 @@ Proof ag32Theory.dfn'JumpIfNotZero_def, ag32_ffi_get_arg_length_loop1_thm, APPLY_UPDATE_THM] \\ CASE_TAC \\ simp[APPLY_UPDATE_THM] - \\ fs[whileTheory.OLEAST_def] + \\ fs[WhileTheory.OLEAST_def] \\ qmatch_goalsub_abbrev_tac`ag32_ffi_get_arg_length_loop s'` \\ first_x_assum(qspec_then`s'`mp_tac) \\ simp[Abbr`s'`, APPLY_UPDATE_THM, ADD1, GSYM word_add_n2w] @@ -1106,7 +1106,7 @@ Proof \\ simp[get_mem_arg_def, GSYM ADD1, UNCURRY] \\ AP_TERM_TAC \\ AP_TERM_TAC - \\ simp[get_next_mem_arg_LEAST, whileTheory.OLEAST_def] + \\ simp[get_next_mem_arg_LEAST, WhileTheory.OLEAST_def] \\ IF_CASES_TAC \\ fs[] QED @@ -1294,7 +1294,7 @@ Theorem ag32_ffi_get_arg_find1_thm: R := ((8w =+ 0w) ((5w =+ s.R 5w + n2w (n+1)) s.R)) |> Proof - reverse(rw[whileTheory.OLEAST_def]) + reverse(rw[WhileTheory.OLEAST_def]) >- ( rw[Once ag32_ffi_get_arg_find1_def] \\ fs[] \\ metis_tac[] ) @@ -1400,7 +1400,7 @@ Proof ag32Theory.incPC_def, ag32Theory.ALU_def, ag32Theory.dfn'JumpIfZero_def, ag32Theory.dfn'JumpIfNotZero_def, ag32_ffi_get_arg_find1_thm, APPLY_UPDATE_THM] - \\ CASE_TAC \\ simp[APPLY_UPDATE_THM] \\ fs[whileTheory.OLEAST_def] + \\ CASE_TAC \\ simp[APPLY_UPDATE_THM] \\ fs[WhileTheory.OLEAST_def] \\ qmatch_goalsub_abbrev_tac`ag32_ffi_get_arg_find s'` \\ first_x_assum(qspec_then`s'`mp_tac) \\ simp[Abbr`s'`, APPLY_UPDATE_THM, ADD1, GSYM word_add_n2w] @@ -1430,12 +1430,12 @@ Proof rw[] \\ rw[get_mem_arg_def] \\ rw[get_next_mem_arg_LEAST] - \\ rw[whileTheory.OLEAST_def] + \\ rw[WhileTheory.OLEAST_def] \\ fs[] ) \\ rw[] \\ fs[] \\ Cases_on`index` \\ fs[get_mem_arg_def] \\ simp[UNCURRY] - \\ simp[get_next_mem_arg_LEAST, whileTheory.OLEAST_def] + \\ simp[get_next_mem_arg_LEAST, WhileTheory.OLEAST_def] \\ IF_CASES_TAC \\ fs[] QED @@ -1511,7 +1511,7 @@ Proof \\ Induct_on`n` \\ rw[] >- ( simp[Once ag32_ffi_get_arg_store_def] - \\ fs[whileTheory.OLEAST_def] + \\ fs[WhileTheory.OLEAST_def] \\ qpat_x_assum`_ = 0n`mp_tac \\ numLib.LEAST_ELIM_TAC \\ conj_tac >- metis_tac[] @@ -1537,7 +1537,7 @@ Proof \\ simp[Once ag32_ffi_get_arg_store_def] \\ IF_CASES_TAC >- ( - fs[whileTheory.OLEAST_def] + fs[WhileTheory.OLEAST_def] \\ first_assum(qspec_then`n'`mp_tac) \\ simp_tac(srw_ss())[DISJ_EQ_IMP] \\ impl_tac >- fs[] \\ strip_tac @@ -1571,7 +1571,7 @@ Proof \\ disch_then(qspec_then`n'`mp_tac) \\ strip_tac \\ fs[] \\ fs[bitTheory.BITS_ZERO3, NOT_LESS_EQUAL, DISJ_EQ_IMP] \\ rw[] - \\ fs[whileTheory.OLEAST_def] + \\ fs[WhileTheory.OLEAST_def] \\ qpat_x_assum`_ = SUC _`mp_tac \\ numLib.LEAST_ELIM_TAC \\ conj_tac >- metis_tac[] @@ -1580,7 +1580,7 @@ Proof \\ simp[] ) \\ qmatch_goalsub_abbrev_tac`ag32_ffi_get_arg_store s'` \\ last_x_assum(qspec_then`s'`mp_tac) - \\ fs[whileTheory.OLEAST_def] + \\ fs[WhileTheory.OLEAST_def] \\ qpat_x_assum`_ = SUC _`mp_tac \\ numLib.LEAST_ELIM_TAC \\ conj_tac >- metis_tac[] diff --git a/compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml b/compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml index 1c90aeca10..08a5c2a831 100644 --- a/compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml +++ b/compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml @@ -2147,7 +2147,7 @@ Proof >- ( rw[bytes_in_memory_APPEND] \\ rw[get_next_mem_arg_LEAST] - \\ simp[whileTheory.OLEAST_def] + \\ simp[WhileTheory.OLEAST_def] \\ reverse IF_CASES_TAC >- ( fs[SNOC_APPEND, bytes_in_memory_APPEND, bytes_in_memory_def] ) \\ simp[] @@ -2169,7 +2169,7 @@ Proof \\ first_x_assum drule \\ disch_then drule \\ rw[] - \\ simp[get_next_mem_arg_LEAST, whileTheory.OLEAST_def] + \\ simp[get_next_mem_arg_LEAST, WhileTheory.OLEAST_def] \\ reverse IF_CASES_TAC >- ( fs[SNOC_APPEND, bytes_in_memory_APPEND, bytes_in_memory_def] ) \\ simp[] @@ -2403,7 +2403,7 @@ Proof \\ qpat_x_assum`a' = a`SUBST_ALL_TAC \\ qpat_x_assum`a = _`(assume_tac o SYM) \\ simp[Abbr`s1`, APPLY_UPDATE_THM] - \\ simp[whileTheory.OLEAST_def] + \\ simp[WhileTheory.OLEAST_def] \\ simp[GSYM CONJ_ASSOC] \\ conj_asm1_tac >- ( diff --git a/compiler/backend/ag32/proofs/ag32_ffi_codeProofScript.sml b/compiler/backend/ag32/proofs/ag32_ffi_codeProofScript.sml index 4f300345e9..0fdab920d6 100644 --- a/compiler/backend/ag32/proofs/ag32_ffi_codeProofScript.sml +++ b/compiler/backend/ag32/proofs/ag32_ffi_codeProofScript.sml @@ -3045,7 +3045,7 @@ Proof Q.REFINE_EXISTS_TAC ‘k + k2’ >> simp0[FUNPOW_ADD] >> simp0[Once LET_THM] >> rev_full_simp_tac (srw_ss()) [] >> ‘(OLEAST n. s2.MEM (s2.R 5w + n2w n) = 0w) = SOME zoff’ - by (glAbbrs 2 >> DEEP_INTRO_TAC whileTheory.OLEAST_INTRO >> simp[] >> + by (glAbbrs 2 >> DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO >> simp[] >> conj_tac >- (goal_assum drule) >> rw[] >> ‘¬(zoff < n) ∧ ¬(n < zoff)’ suffices_by simp[] >> metis_tac[]) >> qpat_x_assum ‘Abbrev (s3 = _)’ mp_tac >> @@ -3436,7 +3436,7 @@ Proof ,ag32Theory.dfn'Normal_def, ag32Theory.norm_def ,ag32Theory.ALU_def, ag32Theory.ri2word_def, ag32Theory.incPC_def] \\ simp[ag32_ffi_get_arg_find1_thm] - \\ simp[whileTheory.OLEAST_def] + \\ simp[WhileTheory.OLEAST_def] \\ IF_CASES_TAC \\ fs[] \\ simp[APPLY_UPDATE_THM] \\ simp[word_add_n2w] @@ -3539,7 +3539,7 @@ Proof (SIMP_RULE bool_ss [PULL_EXISTS] ag32_ffi_get_arg_find_decomp1_thm)>> simp[] >> ‘(OLEAST n. s1.MEM (s1.R 5w + n2w n) = 0w) = SOME off’ - by (DEEP_INTRO_TAC whileTheory.OLEAST_INTRO >> simp[Abbr`s1`] >> + by (DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO >> simp[Abbr`s1`] >> conj_tac >- goal_assum drule >> qx_gen_tac `n` >> strip_tac >> ‘¬(n < off) ∧ ¬(off < n)’ suffices_by simp[] >> metis_tac[]) >> simp[ag32_ffi_get_arg_find1_thm, combinTheory.UPDATE_def] >> @@ -3568,7 +3568,7 @@ Proof ,ag32Theory.dfn'Normal_def, ag32Theory.norm_def ,ag32Theory.ALU_def, ag32Theory.ri2word_def, ag32Theory.incPC_def] \\ simp[ag32_ffi_get_arg_find1_thm] - \\ simp[whileTheory.OLEAST_def] + \\ simp[WhileTheory.OLEAST_def] \\ IF_CASES_TAC \\ fs[] \\ simp[APPLY_UPDATE_THM] \\ simp[word_add_n2w] diff --git a/compiler/backend/proofs/bvl_to_bviProofScript.sml b/compiler/backend/proofs/bvl_to_bviProofScript.sml index 2e828c31a0..dbe07381dd 100644 --- a/compiler/backend/proofs/bvl_to_bviProofScript.sml +++ b/compiler/backend/proofs/bvl_to_bviProofScript.sml @@ -838,7 +838,7 @@ Proof \\ ‘p ≠ new_p ∧ new_p ∉ FDOM s.refs’ by (`∃x. (λptr. ptr NOTIN FDOM (s.refs |+ (p,ARB))) x` by (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM]) - \\ drule whileTheory.LEAST_INTRO \\ fs []) + \\ drule WhileTheory.LEAST_INTRO \\ fs []) \\ fs [] \\ simp [Abbr‘s1’,FLOOKUP_UPDATE,Abbr‘new_refs’,inc_clock_def] \\ disch_then $ qspecl_then [‘T’,‘T’,‘LENGTH ls’] mp_tac @@ -2353,11 +2353,11 @@ Proof \\ `x ∉ FDOM s5.refs` by ( `∃p. (\ptr. ptr ∉ FDOM s5.refs) p` by (rw [] \\ metis_tac [NUM_NOT_IN_FDOM]) - \\ imp_res_tac whileTheory.LEAST_INTRO \\ gvs []) + \\ imp_res_tac WhileTheory.LEAST_INTRO \\ gvs []) \\ `y ∉ FDOM t2.refs` by ( `∃p. (\ptr. ptr ∉ FDOM t2.refs) p` by (rw [] \\ metis_tac [NUM_NOT_IN_FDOM]) - \\ imp_res_tac whileTheory.LEAST_INTRO \\ gvs []) + \\ imp_res_tac WhileTheory.LEAST_INTRO \\ gvs []) \\ gvs [] \\ gvs [bvlSemTheory.do_app_def, AllCaseEqs(), PULL_EXISTS] \\ rw [adjust_bv_def] @@ -2507,12 +2507,12 @@ Proof \\ `~(x IN FDOM s5.refs)` by (`?p. (\ptr. ptr NOTIN FDOM s5.refs) p` by (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM]) - \\ IMP_RES_TAC whileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[] + \\ IMP_RES_TAC WhileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[] \\ REV_FULL_SIMP_TAC std_ss []) \\ `~(y IN FDOM t2.refs)` by (`?p. (\ptr. ptr NOTIN FDOM t2.refs) p` by (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM]) - \\ IMP_RES_TAC whileTheory.LEAST_INTRO + \\ IMP_RES_TAC WhileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[bvi_to_bvl_def] \\ REV_FULL_SIMP_TAC (srw_ss()) [bvi_to_bvl_def]) \\ full_simp_tac(srw_ss())[] @@ -2611,12 +2611,12 @@ Proof \\ `~(x IN FDOM s5.refs)` by (`?p. (\ptr. ptr NOTIN FDOM s5.refs) p` by (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM]) - \\ IMP_RES_TAC whileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[] + \\ IMP_RES_TAC WhileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[] \\ REV_FULL_SIMP_TAC std_ss []) \\ `~(y IN FDOM t2.refs)` by (`?p. (\ptr. ptr NOTIN FDOM t2.refs) p` by (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM]) - \\ IMP_RES_TAC whileTheory.LEAST_INTRO + \\ IMP_RES_TAC WhileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[bvi_to_bvl_def] \\ REV_FULL_SIMP_TAC (srw_ss()) [bvi_to_bvl_def]) \\ full_simp_tac(srw_ss())[] @@ -2705,12 +2705,12 @@ Proof \\ `~(x IN FDOM s5.refs)` by (`?p. (\ptr. ptr NOTIN FDOM s5.refs) p` by (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM]) - \\ IMP_RES_TAC whileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[] + \\ IMP_RES_TAC WhileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[] \\ REV_FULL_SIMP_TAC std_ss []) \\ `~(y IN FDOM t2.refs)` by (`?p. (\ptr. ptr NOTIN FDOM t2.refs) p` by (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM]) - \\ IMP_RES_TAC whileTheory.LEAST_INTRO + \\ IMP_RES_TAC WhileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[bvi_to_bvl_def] \\ REV_FULL_SIMP_TAC (srw_ss()) [bvi_to_bvl_def]) \\ full_simp_tac(srw_ss())[] diff --git a/compiler/backend/proofs/clos_to_bvlProofScript.sml b/compiler/backend/proofs/clos_to_bvlProofScript.sml index d845d776bc..597cb3d4a8 100644 --- a/compiler/backend/proofs/clos_to_bvlProofScript.sml +++ b/compiler/backend/proofs/clos_to_bvlProofScript.sml @@ -4983,7 +4983,7 @@ Proof \\ full_simp_tac(srw_ss())[DRESTRICT_DEF,FAPPLY_FUPDATE_THM] \\ REPEAT STRIP_TAC \\ SRW_TAC [] [] \\ ASSUME_TAC (EXISTS_NOT_IN_refs |> - SIMP_RULE std_ss [whileTheory.LEAST_EXISTS]) \\ full_simp_tac(srw_ss())[]) + SIMP_RULE std_ss [WhileTheory.LEAST_EXISTS]) \\ full_simp_tac(srw_ss())[]) \\ MATCH_MP_TAC IMP_IMP \\ reverse STRIP_TAC >- (REPEAT STRIP_TAC \\ qexists_tac`ck'` @@ -4999,7 +4999,7 @@ Proof \\ full_simp_tac(srw_ss())[DRESTRICT_DEF,FAPPLY_FUPDATE_THM] \\ REPEAT STRIP_TAC \\ SRW_TAC [] [] \\ ASSUME_TAC (EXISTS_NOT_IN_refs |> - SIMP_RULE std_ss [whileTheory.LEAST_EXISTS]) + SIMP_RULE std_ss [WhileTheory.LEAST_EXISTS]) \\ full_simp_tac(srw_ss())[]) \\ conj_tac >- simp [] \\ reverse (REPEAT STRIP_TAC) THEN1 diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml index eefaf6da7a..f3fd842513 100644 --- a/compiler/backend/proofs/data_to_wordProofScript.sml +++ b/compiler/backend/proofs/data_to_wordProofScript.sml @@ -7,7 +7,7 @@ Ancestors data_to_word_gcProof word_to_wordProof wordProps data_to_word wordLang wordSem[qualified] dataProps copying_gc int_bitwise finite_map data_to_word_memoryProof data_to_word_bignumProof - data_to_word_assignProof wordConvs wordConvsProof while set_sep + data_to_word_assignProof wordConvs wordConvsProof While set_sep semanticsProps alignment word_bignum word_bignumProof gen_gc_partial gc_shared gen_gc[qualified] Libs diff --git a/compiler/backend/proofs/data_to_word_assignProofScript.sml b/compiler/backend/proofs/data_to_word_assignProofScript.sml index 5b041e55a5..a6da340927 100644 --- a/compiler/backend/proofs/data_to_word_assignProofScript.sml +++ b/compiler/backend/proofs/data_to_word_assignProofScript.sml @@ -7,7 +7,7 @@ Libs Ancestors data_to_word_memoryProof data_to_word_gcProof dataSem wordSem[qualified] data_to_word int_bitwise dataProps - copying_gc data_to_word_bignumProof wordProps while set_sep + copying_gc data_to_word_bignumProof wordProps While set_sep semanticsProps alignment backendProps word_bignum wordLang word_bignumProof gen_gc_partial gc_shared word_gcFunctions gen_gc[qualified] bvi_to_data[qualified] diff --git a/compiler/backend/proofs/data_to_word_gcProofScript.sml b/compiler/backend/proofs/data_to_word_gcProofScript.sml index 767d476135..8aec2303ce 100644 --- a/compiler/backend/proofs/data_to_word_gcProofScript.sml +++ b/compiler/backend/proofs/data_to_word_gcProofScript.sml @@ -7,7 +7,7 @@ Libs Ancestors mllist dataSem wordSem[qualified] data_to_word backendProps data_to_word_memoryProof dataProps copying_gc int_bitwise - finite_map wordProps while set_sep semanticsProps alignment + finite_map wordProps While set_sep semanticsProps alignment word_bignum wordLang word_bignumProof gen_gc_partial gc_shared word_gcFunctions gen_gc[qualified] diff --git a/compiler/backend/proofs/data_to_word_memoryProofScript.sml b/compiler/backend/proofs/data_to_word_memoryProofScript.sml index 2a13629e59..55c7773c10 100644 --- a/compiler/backend/proofs/data_to_word_memoryProofScript.sml +++ b/compiler/backend/proofs/data_to_word_memoryProofScript.sml @@ -4,7 +4,7 @@ Theory data_to_word_memoryProof Ancestors dataSem dataProps wordSem data_to_word gc_shared gc_combined - word_gcFunctions copying_gc int_bitwise set_sep labSem while + word_gcFunctions copying_gc int_bitwise set_sep labSem While alignment multiword Libs preamble helperLib blastLib[qualified] diff --git a/compiler/backend/proofs/flat_to_closProofScript.sml b/compiler/backend/proofs/flat_to_closProofScript.sml index fd0cd63e05..d019b123dc 100644 --- a/compiler/backend/proofs/flat_to_closProofScript.sml +++ b/compiler/backend/proofs/flat_to_closProofScript.sml @@ -569,7 +569,7 @@ Theorem state_rel_LEAST: Proof fs [state_rel_def,store_rel_def] \\ rw [] \\ ho_match_mp_tac - (whileTheory.LEAST_ELIM + (WhileTheory.LEAST_ELIM |> ISPEC ``\x. x = LENGTH s1.refs`` |> CONV_RULE (DEPTH_CONV BETA_CONV)) \\ fs [] \\ rpt strip_tac \\ fs [FLOOKUP_DEF] diff --git a/compiler/backend/proofs/lab_to_targetProofScript.sml b/compiler/backend/proofs/lab_to_targetProofScript.sml index f50225ac52..4c62fb6763 100644 --- a/compiler/backend/proofs/lab_to_targetProofScript.sml +++ b/compiler/backend/proofs/lab_to_targetProofScript.sml @@ -10349,7 +10349,7 @@ val semantics_compile_lemma = Q.prove( rw[]>> gvs[find_index_LEAST_EL] >> qpat_x_assum `(LEAST n'. _) = n` mp_tac >> - DEEP_INTRO_TAC whileTheory.LEAST_ELIM >> + DEEP_INTRO_TAC WhileTheory.LEAST_ELIM >> conj_tac >- (fs[MEM_EL] >> metis_tac[]) >> simp[] >> diff --git a/compiler/backend/proofs/source_evalProofScript.sml b/compiler/backend/proofs/source_evalProofScript.sml index 892ff0319f..6a9da3db26 100644 --- a/compiler/backend/proofs/source_evalProofScript.sml +++ b/compiler/backend/proofs/source_evalProofScript.sml @@ -1941,7 +1941,7 @@ Proof \\ rw [] \\ first_x_assum (qspec_then `j` mp_tac) \\ simp [extract_oracle_def] - \\ DEEP_INTRO_TAC whileTheory.OLEAST_INTRO + \\ DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO \\ rpt strip_tac >- ( first_x_assum (qspec_then `k` mp_tac) @@ -2009,8 +2009,8 @@ Triviality extract_oracle_SOME_SUC: IS_SOME (extract_oracle s env decs i) Proof simp [extract_oracle_def] - \\ DEEP_INTRO_TAC whileTheory.OLEAST_INTRO - \\ DEEP_INTRO_TAC whileTheory.OLEAST_INTRO + \\ DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO + \\ DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO \\ rw [] \\ simp [UNCURRY] \\ res_tac @@ -2025,7 +2025,7 @@ Triviality extract_oracle_0_st: FST (SND r) = ci.config_v ci.init_state Proof simp [extract_oracle_def] - \\ DEEP_INTRO_TAC whileTheory.OLEAST_INTRO + \\ DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO \\ simp [UNCURRY] \\ rw [] \\ Cases_on `evaluate_decs (s with clock := n) env decs` @@ -2068,7 +2068,7 @@ Proof SUC i < FST (FST ((orac_s t'.eval_state).oracle 0))`) >- ( rpt (POP_ASSUM (mp_tac o REWRITE_RULE [extract_oracle_def])) - \\ DEEP_INTRO_TAC whileTheory.OLEAST_INTRO + \\ DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO \\ rw [] \\ metis_tac [] ) diff --git a/compiler/backend/reg_alloc/parmoveScript.sml b/compiler/backend/reg_alloc/parmoveScript.sml index 6316875ced..c8f80c4419 100644 --- a/compiler/backend/reg_alloc/parmoveScript.sml +++ b/compiler/backend/reg_alloc/parmoveScript.sml @@ -557,9 +557,9 @@ val tac = rw[dstep_cases] >> TRY(map_every qexists_tac[`FST(LAST t')`,`SND(LAST t')`,`FRONT t'`]) >> rw[APPEND_FRONT_LAST] >> - fs[whileTheory.OLEAST_def,MEM_MAP,MEM_EL] >> + fs[WhileTheory.OLEAST_def,MEM_MAP,MEM_EL] >> metis_tac[] ) >> - fs[whileTheory.OLEAST_def] >> + fs[WhileTheory.OLEAST_def] >> BasicProvers.CASE_TAC >- ( fs[DROP_NIL] >> rw[] >> pop_assum mp_tac >> @@ -628,7 +628,7 @@ Termination fs[NULL_LENGTH,LENGTH_NIL] >> simp[LENGTH_FRONT,PRE_SUB1,LENGTH_NOT_NULL,NULL_LENGTH,LENGTH_NIL] >> NO_TAC) >> - fs[whileTheory.OLEAST_def] >> rw[] >> + fs[WhileTheory.OLEAST_def] >> rw[] >> pop_assum mp_tac >> numLib.LEAST_ELIM_TAC >> conj_tac >- metis_tac[] >> diff --git a/compiler/inference/unifyScript.sml b/compiler/inference/unifyScript.sml index cb8bad59da..5b9df80eef 100644 --- a/compiler/inference/unifyScript.sml +++ b/compiler/inference/unifyScript.sml @@ -804,7 +804,7 @@ Theorem cvwalk_tcallish: ∀x. (λn. cwfs s) x ⇒ cvwalk s x = TAILCALL (cvwalk_code s) (cvwalk s) x Proof - simp[whileTheory.TAILCALL_def, cvwalk_code_def, sum_CASE_option_CASE, + simp[WhileTheory.TAILCALL_def, cvwalk_code_def, sum_CASE_option_CASE, sum_CASE_infer_CASE, FORALL_PROD] >> simp[Once (DISCH_ALL cvwalk_thm), cwfs_def] QED @@ -812,7 +812,7 @@ QED Theorem cvwalk_cleaned: ∀x. (λn. cwfs s) x ⇒ cvwalk s x = TAILREC (cvwalk_code s) x Proof - match_mp_tac whileTheory.TAILREC_GUARD_ELIMINATION >> + match_mp_tac WhileTheory.TAILREC_GUARD_ELIMINATION >> rpt conj_tac >- ACCEPT_TAC cvwalk_preserves_precond >- (rpt strip_tac >> qexists_tac ‘cvwalkR s’ >> conj_tac @@ -831,7 +831,7 @@ Proof simp[FUN_EQ_THM] QED Theorem tcvwalk_thm = - tcvwalk_def |> SRULE[Once whileTheory.TAILREC, cvwalk_code_def] + tcvwalk_def |> SRULE[Once WhileTheory.TAILREC, cvwalk_code_def] |> SRULE[sum_CASE_option_CASE, sum_CASE_infer_CASE] |> SRULE[GSYM tcvwalk_def, cvwalk_eta, GSYM (SRULE [FUN_EQ_THM] cvwalk_code_def)] @@ -1180,7 +1180,7 @@ Theorem kcocwl_tcallish: ∀x. (λv. cwfs s) x ⇒ kcocwl s n x = TAILCALL (kcocwl_code s n) (kcocwl s n) x Proof - simp[FORALL_PROD, whileTheory.TAILCALL_def, kcocwl_code_def, + simp[FORALL_PROD, WhileTheory.TAILCALL_def, kcocwl_code_def, sum_CASE_list_CASE, sum_CASE_infer_CASE, sum_CASE_COND] >> rpt strip_tac >> rename [‘kcocwl s n wl ⇔ _’] >> Cases_on ‘wl’ >> simp[Once kcocwl_thm, SimpLHS] >> @@ -1190,7 +1190,7 @@ QED Theorem kcocwl_cleaned: ∀x. (λv. cwfs s) x ⇒ kcocwl s n x = TAILREC (kcocwl_code s n) x Proof - match_mp_tac whileTheory.TAILREC_GUARD_ELIMINATION >> rpt conj_tac + match_mp_tac WhileTheory.TAILREC_GUARD_ELIMINATION >> rpt conj_tac >- ACCEPT_TAC kcocwl_preserves_precond >- (qx_gen_tac ‘wl’ >> strip_tac >> qexists ‘kcocwlR s n’ >> conj_tac @@ -1216,7 +1216,7 @@ Theorem disj2cond[local] = DECIDE “p ∨ q ⇔ if p then T else q” Theorem tcocwl_thm = tcocwl_def - |> SRULE[Once whileTheory.TAILREC, sum_CASE_list_CASE, + |> SRULE[Once WhileTheory.TAILREC, sum_CASE_list_CASE, sum_CASE_infer_CASE, sum_CASE_COND, kcocwl_code_def] |> SRULE [GSYM tcocwl_def, GSYM kcocwl_code_def] |> PURE_REWRITE_RULE [disj2cond] @@ -1457,7 +1457,7 @@ Theorem kcwalkstarwl_tcallish: (λ(v,its,k). kcwalkstarwl s v its k) x = TAILCALL (kcwalkstarwl_code s) (λ(v,its,k). kcwalkstarwl s v its k) x Proof - simp[whileTheory.TAILCALL_def, kcwalkstarwl_code_def, FORALL_PROD, + simp[WhileTheory.TAILCALL_def, kcwalkstarwl_code_def, FORALL_PROD, sum_CASE_COND, sum_CASE_list_CASE, sum_CASE_infer_CASE, sum_CASE_wstarcont_CASE] >> simp[Once $ DISCH_ALL kcwalkstarwl_thm] @@ -1467,7 +1467,7 @@ Theorem kcwalkstarwl_cleaned: ∀x. (λ(v,its,k). cwfs s) x ⇒ (λ(v,its,k). kcwalkstarwl s v its k) x = TAILREC (kcwalkstarwl_code s) x Proof - match_mp_tac whileTheory.TAILREC_GUARD_ELIMINATION >> rpt conj_tac + match_mp_tac WhileTheory.TAILREC_GUARD_ELIMINATION >> rpt conj_tac >- ACCEPT_TAC kcwalkstarwl_preserves_precond >- (qx_gen_tac ‘trip’ >> strip_tac >> qexists ‘kcwalkstarwlR s’ >> conj_tac @@ -1491,7 +1491,7 @@ End Theorem tcwalkstarwl_thm = tcwalkstarwl_def - |> SRULE[Once whileTheory.TAILREC] + |> SRULE[Once WhileTheory.TAILREC] |> SRULE[kcwalkstarwl_code_def, sum_CASE_COND, sum_CASE_wstarcont_CASE, sum_CASE_list_CASE, sum_CASE_infer_CASE] @@ -1600,7 +1600,7 @@ Theorem kcunifywl_tcallish: (λ(s,k). kcunifywl s k) x = TAILCALL cunify_code (λ(s,k). kcunifywl s k) x Proof - simp[whileTheory.TAILCALL_def, FORALL_PROD, sum_CASE_list_CASE, + simp[WhileTheory.TAILCALL_def, FORALL_PROD, sum_CASE_list_CASE, cunify_code_def, sum_CASE_pair_CASE, sum_CASE_infer_CASE, sum_CASE_COND] >> qx_genl_tac [‘s’, ‘k’] >> strip_tac >> @@ -1992,7 +1992,7 @@ Theorem kcunifywl_cleaned: ∀x. (λ(s,wl). cwfs s) x ⇒ (λ(s,wl). kcunifywl s wl) x = TAILREC cunify_code x Proof - match_mp_tac whileTheory.TAILREC_GUARD_ELIMINATION >> rpt conj_tac + match_mp_tac WhileTheory.TAILREC_GUARD_ELIMINATION >> rpt conj_tac >- ACCEPT_TAC kcunifywl_preserves_precond >- (rpt strip_tac >> qexists ‘kcunifywlR’ >> conj_tac >- (irule $ iffLR WF_EQ_WFP >> simp[WF_kcunifywlR]) >> @@ -2005,7 +2005,7 @@ Definition tcunify_def: End Theorem tcunify_thm = - tcunify_def |> SRULE[Once whileTheory.TAILREC] + tcunify_def |> SRULE[Once WhileTheory.TAILREC] |> SRULE[cunify_code_def, sum_CASE_list_CASE, sum_CASE_pair_CASE, sum_CASE_infer_CASE, sum_CASE_COND] diff --git a/examples/filterProgScript.sml b/examples/filterProgScript.sml index 4b9b7dab74..331256848e 100644 --- a/examples/filterProgScript.sml +++ b/examples/filterProgScript.sml @@ -998,7 +998,7 @@ Proof impl_tac >- rw[every_LNTH,LNTH_LGENLIST,next_filter_events,LFINITE_fromList] >> simp[SimpL ``$==>``,exists_LNTH,LNTH_LGENLIST] >> Ho_Rewrite.PURE_ONCE_REWRITE_TAC [cut_at_null_simplify] >> - disch_then(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[whileTheory.LEAST_EXISTS]) >> + disch_then(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[WhileTheory.LEAST_EXISTS]) >> rename1 `LNTH n0` >> qmatch_goalsub_abbrev_tac `LGENLIST f` >> Q.ISPECL_THEN [`n0`,`f`] assume_tac (GEN_ALL LGENLIST_CHUNK_GENLIST) >> @@ -1047,7 +1047,7 @@ Proof impl_tac >- rw[every_LNTH,LNTH_LGENLIST,next_filter_events,LFINITE_fromList] >> simp[SimpL ``$==>``,exists_LNTH,LNTH_LGENLIST] >> Ho_Rewrite.PURE_ONCE_REWRITE_TAC [cut_at_null_simplify] >> - disch_then(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[whileTheory.LEAST_EXISTS]) >> + disch_then(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[WhileTheory.LEAST_EXISTS]) >> rename1 `LNTH n0` >> qmatch_goalsub_abbrev_tac `LGENLIST f` >> Q.ISPECL_THEN [`n0`,`f`] assume_tac (GEN_ALL LGENLIST_CHUNK_GENLIST) >> diff --git a/misc/miscScript.sml b/misc/miscScript.sml index 7caef2aa60..d556ae6d1c 100644 --- a/misc/miscScript.sml +++ b/misc/miscScript.sml @@ -2293,8 +2293,8 @@ QED Theorem OLEAST_SOME_IMP: $OLEAST P = SOME i ⇒ P i ∧ (∀n. n < i ⇒ ¬P n) Proof - simp[whileTheory.OLEAST_def] - \\ metis_tac[whileTheory.LEAST_EXISTS_IMP] + simp[WhileTheory.OLEAST_def] + \\ metis_tac[WhileTheory.LEAST_EXISTS_IMP] QED Theorem EXP2_EVEN: diff --git a/pancake/semantics/panItreeSemScript.sml b/pancake/semantics/panItreeSemScript.sml index ce4ce941b4..3454f575ca 100644 --- a/pancake/semantics/panItreeSemScript.sml +++ b/pancake/semantics/panItreeSemScript.sml @@ -714,7 +714,7 @@ Theorem ltree_lift_state_simps: ltree_lift_state f st' ((g ∘ (SND ek)) a) Proof rpt conj_tac >> - rw[ltree_lift_state_def, Once whileTheory.WHILE] >> + rw[ltree_lift_state_def, Once WhileTheory.WHILE] >> rw[ELIM_UNCURRY] >> PURE_TOP_CASE_TAC >> rw[] QED diff --git a/translator/std_preludeScript.sml b/translator/std_preludeScript.sml index 6ca46ff8de..2a46eeee37 100644 --- a/translator/std_preludeScript.sml +++ b/translator/std_preludeScript.sml @@ -4,7 +4,7 @@ *) Theory std_prelude Ancestors - ast semanticPrimitives while evaluate ml_translator + ast semanticPrimitives While evaluate ml_translator Libs preamble ml_translatorLib ml_progLib From 385dc18c26e47b9c6d5c7cf594532de3b88685b1 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 25 Sep 2025 03:17:02 +0300 Subject: [PATCH 099/112] Reverse changes to alt semantics for force clocks --- semantics/alt_semantics/bigStepScript.sml | 29 +++----- .../alt_semantics/proofs/bigClockScript.sml | 40 ++++------- .../proofs/bigSmallEquivScript.sml | 69 +++---------------- .../proofs/bigSmallInvariantsScript.sml | 30 ++++---- .../alt_semantics/proofs/interpScript.sml | 29 ++++---- 5 files changed, 55 insertions(+), 142 deletions(-) diff --git a/semantics/alt_semantics/bigStepScript.sml b/semantics/alt_semantics/bigStepScript.sml index 3e8d11f9c1..c7280d46cc 100644 --- a/semantics/alt_semantics/bigStepScript.sml +++ b/semantics/alt_semantics/bigStepScript.sml @@ -178,19 +178,8 @@ evaluate ck env s1 (App op es) (( s2 with<| refs := refs'; ffi :=ffi' |>), res)) evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) ∧ opClass op Force ∧ dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧ - ck ∧ s2.clock = 0 - ⇒ evaluate ck env s1 (App op es) (s2, Rerr (Rabort Rtimeout_error))) - -∧ - -(∀ck env op es vs s1 s2 f. - evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) ∧ - opClass op Force ∧ - dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧ - (ck ⇒ s2.clock ≠ 0) ∧ do_opapp [f; Conv NONE []] = NONE - ⇒ evaluate ck env s1 (App op es) - (if ck then s2 with clock := s2.clock - 1 else s2, Rerr (Rabort Rtype_error))) + ⇒ evaluate ck env s1 (App op es) (s2, Rerr (Rabort Rtype_error))) ∧ @@ -207,8 +196,8 @@ evaluate ck env s1 (App op es) (( s2 with<| refs := refs'; ffi :=ffi' |>), res)) opClass op Force ∧ dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧ do_opapp [f; Conv NONE []] = SOME env_e ∧ - ck ∧ s2.clock = 1 - ⇒ evaluate ck env s1 (App op es) (s2 with clock := 0, Rerr (Rabort Rtimeout_error))) + ck ∧ s2.clock = 0 + ⇒ evaluate ck env s1 (App op es) (s2, Rerr (Rabort Rtimeout_error))) ∧ @@ -217,8 +206,8 @@ evaluate ck env s1 (App op es) (( s2 with<| refs := refs'; ffi :=ffi' |>), res)) opClass op Force ∧ dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧ do_opapp [f; Conv NONE []] = SOME (env', e) ∧ - (ck ⇒ ¬(s2.clock ≤ 1)) ∧ - evaluate ck env' (if ck then (s2 with clock := s2.clock - 2) else s2) e (s3, Rerr err) + (ck ⇒ s2.clock ≠ 0) ∧ + evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rerr err) ⇒ evaluate ck env s1 (App op es) (s3, Rerr err)) ∧ @@ -228,8 +217,8 @@ evaluate ck env s1 (App op es) (( s2 with<| refs := refs'; ffi :=ffi' |>), res)) opClass op Force ∧ dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧ do_opapp [f; Conv NONE []] = SOME (env', e) ∧ - (ck ⇒ ¬(s2.clock ≤ 1)) ∧ - evaluate ck env' (if ck then (s2 with clock := s2.clock - 2) else s2) e (s3, Rval vs2) ∧ + (ck ⇒ s2.clock ≠ 0) ∧ + evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rval vs2) ∧ update_thunk (REVERSE vs) s3.refs [vs2] = NONE ⇒ evaluate ck env s1 (App op es) (s3, Rerr (Rabort Rtype_error))) @@ -240,8 +229,8 @@ evaluate ck env s1 (App op es) (( s2 with<| refs := refs'; ffi :=ffi' |>), res)) opClass op Force ∧ dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧ do_opapp [f; Conv NONE []] = SOME (env', e) ∧ - (ck ⇒ ¬(s2.clock ≤ 1)) ∧ - evaluate ck env' (if ck then (s2 with clock := s2.clock - 2) else s2) e (s3, Rval vs2) ∧ + (ck ⇒ s2.clock ≠ 0) ∧ + evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rval vs2) ∧ update_thunk (REVERSE vs) s3.refs [vs2] = SOME refs ⇒ evaluate ck env s1 (App op es) (s3 with refs := refs, Rval vs2)) diff --git a/semantics/alt_semantics/proofs/bigClockScript.sml b/semantics/alt_semantics/proofs/bigClockScript.sml index 6d042ef8b9..9b42c6f429 100644 --- a/semantics/alt_semantics/proofs/bigClockScript.sml +++ b/semantics/alt_semantics/proofs/bigClockScript.sml @@ -131,7 +131,6 @@ Proof >- metis_tac[] >- metis_tac[] >- metis_tac[] - >- metis_tac[] >- ( ntac 3 disj2_tac >> disj1_tac >> last_x_assum $ irule_at Any >> simp[] @@ -301,26 +300,21 @@ Proof first_assum(match_exists_tac o concl) >> simp[] >> NO_TAC) >>~ [‘ThunkOp ForceThunk’] >- ( - gvs[] >> ntac 2 disj2_tac >> disj1_tac >> - dxrule $ cj 2 add_to_counter >> simp[] >> - disch_then $ qspec_then ‘1’ $ irule_at Any >> simp[] - ) - >- ( - gvs[] >> ntac 5 disj2_tac >> disj1_tac >> + gvs[] >> ntac 4 disj2_tac >> disj1_tac >> dxrule $ cj 2 add_to_counter >> simp[] >> - disch_then $ qspec_then ‘c' + 2’ $ irule_at Any >> simp[] >> - goal_assum drule + disch_then $ qspec_then ‘c' + 1’ assume_tac >> + goal_assum drule >> simp[] ) >- ( gvs[] >> ntac 4 disj2_tac >> disj1_tac >> dxrule $ cj 2 add_to_counter >> simp[] >> - disch_then $ qspec_then ‘c' + 2’ assume_tac >> + disch_then $ qspec_then ‘c' + 1’ assume_tac >> rpt (goal_assum drule >> simp[]) ) >- ( gvs[] >> disj2_tac >> dxrule $ cj 2 add_to_counter >> simp[] >> - disch_then $ qspec_then ‘c' + 2’ assume_tac >> + disch_then $ qspec_then ‘c' + 1’ assume_tac >> goal_assum $ drule_at Any >> simp[] >> goal_assum $ drule_at $ Pat ‘evaluate _ _ _ _ _’ >> simp[] ) >> @@ -602,19 +596,17 @@ Proof ntac 2 disj2_tac >> Cases_on ‘t’ >> gvs[] >- metis_tac[] >> rename1 ‘IsThunk _ f’ >> - Cases_on ‘s2.clock = 0’ >- metis_tac[] >> Cases_on ‘do_opapp [f; Conv NONE []]’ >- metis_tac[] >> - Cases_on ‘s2.clock = 1’ >- metis_tac[] >> - ‘¬(s2.clock ≤ 1)’ by gvs[] >> gvs[] >> rename1 ‘SOME env_e’ >> PairCases_on ‘env_e’ >> - ntac 4 disj2_tac >> - last_x_assum $ qspec_then ‘s2.clock - 2’ mp_tac >> + ntac 2 disj2_tac >> + Cases_on ‘s2.clock = 0’ >- metis_tac[] >> + disj2_tac >> + last_x_assum $ qspec_then ‘s2.clock - 1’ mp_tac >> last_x_assum kall_tac >> impl_tac >- (imp_res_tac clock_monotone >> gvs[]) >> disch_then $ qspecl_then [‘env_e1’,‘env_e0’,‘s2’] $ qx_choosel_then [‘s3’,‘res’] assume_tac >> - reverse $ Cases_on ‘res’ - >- metis_tac[] >> + reverse $ Cases_on ‘res’ >- metis_tac[] >> disj2_tac >> Cases_on ‘update_thunk (REVERSE v) s3.refs [a]’ >> metis_tac[] ) >> `(do_app (s2.refs,s2.ffi) o' (REVERSE v) = NONE) ∨ @@ -806,18 +798,10 @@ Proof >- simp[SF SFY_ss] >- simp[SF SFY_ss] >- simp[SF SFY_ss] - >- ( - ntac 5 disj2_tac >> disj1_tac >> - last_x_assum $ irule_at Any >> simp[] >> - qexists ‘count'' + 1’ >> simp[] - ) + >- simp[SF SFY_ss] >- simp[SF SFY_ss] >- ( - ntac 4 disj2_tac >> disj1_tac >> - last_x_assum $ irule_at Any >> simp[] - ) - >- ( - ntac 9 disj2_tac >> disj1_tac >> + ntac 8 disj2_tac >> disj1_tac >> last_x_assum $ irule_at Any >> simp[] >> first_x_assum $ irule_at Any >> simp[] >> qexists ‘s2.clock - extra’ >> simp[] >> diff --git a/semantics/alt_semantics/proofs/bigSmallEquivScript.sml b/semantics/alt_semantics/proofs/bigSmallEquivScript.sml index f568212f55..eb9cd5ce0f 100644 --- a/semantics/alt_semantics/proofs/bigSmallEquivScript.sml +++ b/semantics/alt_semantics/proofs/bigSmallEquivScript.sml @@ -872,26 +872,14 @@ Proof >- ( disj2_tac >> disj1_tac >> simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss] ) - >- simp[SF SFY_ss] - >- ( - ntac 2 disj2_tac >> disj1_tac >> - simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss] >> - irule_at Any EQ_REFL >> simp[SF SFY_ss] - ) >- ( ntac 2 disj2_tac >> disj1_tac >> simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss] ) + >- simp[SF SFY_ss] + >- simp[SF SFY_ss] >- ( - disj1_tac >> rpt $ goal_assum $ drule_at Any >> - qspec_then ‘s2'’ assume_tac $ GEN_ALL with_same_clock >> gvs[] - ) - >- ( - disj2_tac >> disj1_tac >> irule_at Any EQ_REFL >> - simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss] - ) - >- ( - ntac 5 disj2_tac >> disj1_tac >> + ntac 4 disj2_tac >> disj1_tac >> simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss] ) >- ( @@ -977,37 +965,13 @@ Proof by gvs[getOpClass_opClass, opClass_cases] >> simp[SF DNF_ss, GSYM DISJ_ASSOC] >> gvs[AllCaseEqs()] >- ( - ntac 2 disj2_tac >> disj1_tac >> simp[Once evaluate_cases, SF SFY_ss] + ntac 3 disj2_tac >> disj1_tac >> simp[Once evaluate_cases, SF SFY_ss] ) >> once_rewrite_tac[cj 2 evaluate_cases] >> simp[] >> gvs[evaluate_ctxts_cons] >> gvs[evaluate_ctxt_cases, update_thunk_def, AllCaseEqs(), SF SFY_ss] >> - gvs[Once $ cj 2 evaluate_cases, opClass_cases] >> - (reverse $ Cases_on ‘ck’ >> gvs[] >- metis_tac[]) - >- ( - ntac 3 disj2_tac >> disj1_tac >> - qexists ‘clk + 1’ >> simp[] >> goal_assum drule >> simp[] - ) - >- ( - ntac 3 disj2_tac >> disj1_tac >> - qexists ‘clk + 1’ >> simp[] >> goal_assum drule >> simp[] - ) - >- ( - ntac 3 disj2_tac >> disj1_tac >> - qexists ‘clk + 1’ >> simp[] >> goal_assum drule >> simp[] - ) - >- ( - rpt disj2_tac >> - qexists ‘clk + 1’ >> simp[] >> goal_assum drule >> simp[] - ) - >- ( - ntac 2 disj2_tac >> disj1_tac >> - qexists ‘clk + 1’ >> simp[] >> goal_assum drule >> simp[] - ) - >- ( - disj1_tac >> - qexists ‘clk + 1’ >> simp[] >> goal_assum drule >> simp[] - ) + gvs[Once $ cj 2 evaluate_cases] >> + gvs[opClass_cases] >> metis_tac[] ) >> once_rewrite_tac[cj 2 evaluate_cases] >> simp[] >> every_case_tac >> gvs[SF DNF_ss, SF SFY_ss] >> @@ -1819,20 +1783,7 @@ Proof >- ( (* App - do_app timeout *) drule do_app_not_timeout >> simp[] ) - >- ( (* Force - timeout 1 *) - dxrule big_clocked_to_unclocked_list >> rw[] >> - dxrule $ cj 2 big_exp_to_small_exp >> rw[] >> - gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_res_def] >> - imp_res_tac small_eval_list_length >> gvs[LENGTH_EQ_NUM_compute] >> - ntac 2 $ gvs[Once small_eval_list_cases] >> - irule_at Any $ cj 2 RTC_rules >> - simp[e_step_reln_def, e_step_def, push_def, application_thm] >> - irule_at Any $ cj 2 RTC_RULES_RIGHT1 >> - dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >> - simp[e_step_reln_def, e_step_def, continue_def, application_thm, getOpClass_def] >> - gvs[dest_thunk_def, to_small_st_def] - ) - >- ( (* Force - timeout 2 *) + >- ( (* Force - timeout *) dxrule big_clocked_to_unclocked_list >> rw[] >> dxrule $ cj 2 big_exp_to_small_exp >> rw[] >> gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_res_def] >> @@ -2300,12 +2251,10 @@ Proof rename1 ‘evaluate_list _ _ _ _ (s2,Rval vs2)’ >> Cases_on ‘dest_thunk (REVERSE vs2 ++ [v] ++ l) s2.refs’ >> gvs[SF SFY_ss] >> rename1 ‘IsThunk t f’ >> Cases_on ‘t’ >> gvs[SF SFY_ss] >> - Cases_on ‘s2.clock = 0’ >> gvs[SF SFY_ss] >> Cases_on ‘do_opapp [f; Conv NONE []]’ >> gvs[SF SFY_ss] >> rename1 ‘SOME env_e’ >> PairCases_on ‘env_e’ >> - Cases_on ‘s2.clock = 1’ >> gvs[SF SFY_ss] >> - ‘¬ (s2.clock ≤ 1)’ by gvs[] >> gvs[] >> - qspecl_then [‘s2 with clock := s2.clock - 2’,‘env_e0’,‘env_e1’] + Cases_on ‘s2.clock = 0’ >> gvs[SF SFY_ss] >> + qspecl_then [‘s2 with clock := s2.clock - 1’,‘env_e0’,‘env_e1’] assume_tac big_clocked_total >> gvs[] >> rename1 ‘evaluate _ _ _ _ (s3, res)’ >> Cases_on ‘res’ >> gvs[SF SFY_ss] >> rename1 ‘Rval v'’ >> diff --git a/semantics/alt_semantics/proofs/bigSmallInvariantsScript.sml b/semantics/alt_semantics/proofs/bigSmallInvariantsScript.sml index f4b1773c28..06902a4028 100644 --- a/semantics/alt_semantics/proofs/bigSmallInvariantsScript.sml +++ b/semantics/alt_semantics/proofs/bigSmallInvariantsScript.sml @@ -45,7 +45,9 @@ Inductive evaluate_ctxt: (opClass op Force ∧ evaluate_list ck env s1 es (s2, Rval vs2) ∧ (dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = BadRef ∨ - dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = NotThunk) + dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = NotThunk ∨ + (dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧ + do_opapp [f; Conv NONE []] = NONE)) ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v (s2, Rerr (Rabort Rtype_error))) ∧ @@ -54,28 +56,20 @@ Inductive evaluate_ctxt: dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk Evaluated v' ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v (s2, Rval v')) ∧ - (opClass op Force ∧ - evaluate_list ck env s1 es (s2, Rval vs2) ∧ - dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧ - (ck ⇒ s2.clock ≠ 0) ∧ - do_opapp [f; Conv NONE []] = NONE - ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v - (if ck then s2 with clock := s2.clock - 1 else s2, Rerr (Rabort Rtype_error))) ∧ - (opClass op Force ∧ evaluate_list T env s1 es (s2, Rval vs2) ∧ dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧ - (s2.clock = 0 ∨ - (s2.clock = 1 ∧ do_opapp [f; Conv NONE []] = SOME env_e)) + do_opapp [f; Conv NONE []] = SOME env_e ∧ + s2.clock = 0 ⇒ evaluate_ctxt T env s1 (Capp op vs1 () es) v - (s2 with clock := 0, Rerr (Rabort Rtimeout_error))) ∧ + (s2, Rerr (Rabort Rtimeout_error))) ∧ (opClass op Force ∧ evaluate_list ck env s1 es (s2, Rval vs2) ∧ dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧ do_opapp [f; Conv NONE []] = SOME (env', e) ∧ - (ck ⇒ ¬(s2.clock ≤ 1)) ∧ - evaluate ck env' (if ck then (s2 with clock := s2.clock - 2) else s2) e (s3, Rerr err) + (ck ⇒ s2.clock ≠ 0) ∧ + evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rerr err) ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v (s3, Rerr err)) ∧ @@ -83,8 +77,8 @@ Inductive evaluate_ctxt: evaluate_list ck env s1 es (s2, Rval vs2) ∧ dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧ do_opapp [f; Conv NONE []] = SOME (env', e) ∧ - (ck ⇒ ¬(s2.clock ≤ 1)) ∧ - evaluate ck env' (if ck then (s2 with clock := s2.clock - 2) else s2) e (s3, Rval v') ∧ + (ck ⇒ s2.clock ≠ 0) ∧ + evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rval v') ∧ update_thunk (REVERSE vs2 ++ [v] ++ vs1) s3.refs [v'] = NONE ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v (s3, Rerr (Rabort Rtype_error))) ∧ @@ -93,8 +87,8 @@ Inductive evaluate_ctxt: evaluate_list ck env s1 es (s2, Rval vs2) ∧ dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧ do_opapp [f; Conv NONE []] = SOME (env', e) ∧ - (ck ⇒ ¬(s2.clock ≤ 1)) ∧ - evaluate ck env' (if ck then (s2 with clock := s2.clock - 2) else s2) e (s3, Rval v') ∧ + (ck ⇒ s2.clock ≠ 0) ∧ + evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rval v') ∧ update_thunk (REVERSE vs2 ++ [v] ++ vs1) s3.refs [v'] = SOME refs ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v (s3 with refs := refs, Rval v')) ∧ diff --git a/semantics/alt_semantics/proofs/interpScript.sml b/semantics/alt_semantics/proofs/interpScript.sml index 85d03f6ca4..85e684aa4a 100644 --- a/semantics/alt_semantics/proofs/interpScript.sml +++ b/semantics/alt_semantics/proofs/interpScript.sml @@ -213,22 +213,19 @@ Theorem run_eval_def: | NotThunk => raise (Rabort Rtype_error) | IsThunk Evaluated v => return v | IsThunk NotEvaluated f => - do - () <- dec_clock; - case do_opapp [f; Conv NONE []] of - | SOME (env',e) => do - () <- dec_clock; - v2 <- run_eval env' e; - ^st <- get_store; - (case update_thunk (REVERSE vs) st.refs [v2] of - | NONE => raise (Rabort Rtype_error) - | SOME refs => do - () <- set_store (st with refs := refs); - return v2; - od) - od - | NONE => raise (Rabort Rtype_error) - od) + case do_opapp [f; Conv NONE []] of + | SOME (env',e) => do + () <- dec_clock; + v2 <- run_eval env' e; + ^st <- get_store; + (case update_thunk (REVERSE vs) st.refs [v2] of + | NONE => raise (Rabort Rtype_error) + | SOME refs => do + () <- set_store (st with refs := refs); + return v2; + od) + od + | NONE => raise (Rabort Rtype_error)) | Simple => (case do_app (st.refs,st.ffi) op (REVERSE vs) of | NONE => raise (Rabort Rtype_error) From ca8876408923942206ed2b8c1f90add4d12d098a Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Mon, 29 Sep 2025 18:08:06 +0200 Subject: [PATCH 100/112] Fix cv translation --- cv_translator/backend_32_cvScript.sml | 3 ++- cv_translator/backend_64_cvScript.sml | 8 +------- 2 files changed, 3 insertions(+), 8 deletions(-) diff --git a/cv_translator/backend_32_cvScript.sml b/cv_translator/backend_32_cvScript.sml index 88e6afc687..5eecf3ad42 100644 --- a/cv_translator/backend_32_cvScript.sml +++ b/cv_translator/backend_32_cvScript.sml @@ -542,6 +542,8 @@ val _ = cv_trans (data_to_wordTheory.assign_def |> arch_spec |> SRULE data_to_wordTheory.arg3_def, data_to_wordTheory.arg4_def]) +val _ = cv_trans (data_to_wordTheory.force_thunk_def |> arch_spec); + val pre = data_to_wordTheory.comp_def |> arch_spec |> SRULE [to_adjust_vars] |> cv_trans_pre ""; Theorem data_to_word_comp_pre[cv_pre,local]: ∀c secn l p. data_to_word_comp_pre c secn l p @@ -573,4 +575,3 @@ Proof QED val _ = word_allocTheory.get_heuristics_def |> arch_spec |> cv_auto_trans; - diff --git a/cv_translator/backend_64_cvScript.sml b/cv_translator/backend_64_cvScript.sml index 86ec1fa547..b98843126d 100644 --- a/cv_translator/backend_64_cvScript.sml +++ b/cv_translator/backend_64_cvScript.sml @@ -542,12 +542,7 @@ val _ = cv_trans (data_to_wordTheory.assign_def |> arch_spec |> SRULE data_to_wordTheory.arg3_def, data_to_wordTheory.arg4_def]) -val pre = cv_trans_pre "" (data_to_wordTheory.force_thunk_def |> arch_spec); -Theorem data_to_word_force_thunk_pre[cv_pre,local]: - ∀c secn l ret loc v1. data_to_word_force_thunk_pre c secn l ret loc v1 -Proof - cheat -QED +val _ = cv_trans (data_to_wordTheory.force_thunk_def |> arch_spec); val pre = data_to_wordTheory.comp_def |> arch_spec |> SRULE [to_adjust_vars] |> cv_trans_pre ""; Theorem data_to_word_comp_pre[cv_pre,local]: @@ -580,4 +575,3 @@ Proof QED val _ = word_allocTheory.get_heuristics_def |> arch_spec |> cv_auto_trans; - From b9870043f86c480d4ff2007e28c18b0cd31357aa Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Mon, 29 Sep 2025 18:08:25 +0200 Subject: [PATCH 101/112] Progress on some cheats --- .../proofs/data_to_wordProofScript.sml | 73 +++++++++++++++---- 1 file changed, 57 insertions(+), 16 deletions(-) diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml index f3fd842513..dbf8a6e2d4 100644 --- a/compiler/backend/proofs/data_to_wordProofScript.sml +++ b/compiler/backend/proofs/data_to_wordProofScript.sml @@ -135,6 +135,22 @@ Proof \\ SEP_R_TAC \\ fs [] QED +Theorem MEM_join_env_cut_env: + ∀(a:v # α word_loc) t r s. + MEM a (join_env x (toAList (inter t (adjust_set x)))) ∧ + dataSem$cut_env r s = SOME x ⇒ + MEM a (join_env s (toAList (inter t (adjust_set s)))) +Proof + fs [join_env_def,MEM_MAP,EXISTS_PROD,MEM_FILTER] + \\ rw [] \\ gvs [cut_env_def] + \\ fs [MEM_toAList] + \\ last_assum $ irule_at Any \\ simp [] + \\ fs [lookup_inter_alt,IN_domain_adjust_set_inter] + \\ rw [] \\ fs [] + \\ imp_res_tac IN_adjust_set_IN +QED + +(* Theorem state_rel_call_env_get_var: get_var src s.locals = SOME (RefPtr v0 ptr) /\ get_var (adjust_var src) (t:('a,'c,'ffi) wordSem$state) = SOME w /\ @@ -171,6 +187,7 @@ Proof \\ full_simp_tac(srw_ss())[DIV_LT_X] \\ cheat QED +*) Theorem data_compile_correct: !prog s c n l l1 l2 res s1 (t:('a,'c,'ffi)wordSem$state) locs. @@ -201,6 +218,7 @@ Theorem data_compile_correct: | SOME (Rerr (Rabort(Rffi_error f))) => (res1 = SOME(FinalFFI f) /\ t1.ffi = s1.ffi) | SOME (Rerr (Rabort e)) => (res1 = SOME TimeOut) /\ t1.ffi = s1.ffi) Proof + recInduct dataSemTheory.evaluate_ind \\ rpt strip_tac \\ fs [] >~ [‘evaluate (Skip,s)’] >- (fs [comp_def,dataSemTheory.evaluate_def,wordSemTheory.evaluate_def] @@ -248,7 +266,10 @@ Proof \\ fs [cut_state_def,cut_env_def] \\ every_case_tac \\ fs [] \\ rw [] \\ fs [set_var_def]) >~ [‘evaluate (Force _ _ _,s)’] >- - (simp [comp_def, force_thunk_def] + + ( + + simp [comp_def, force_thunk_def] \\ TOP_CASE_TAC \\ gvs [] >- gvs [encode_header_def, encode_header_def, state_rel_def, good_dimindex_def, limits_inv_def, dimword_def, memory_rel_def, @@ -282,7 +303,8 @@ Proof \\ simp [list_Seq_def, wordSemTheory.evaluate_def] \\ simp [wordSemTheory.get_var_def, wordSemTheory.get_var_imm_def] \\ drule_all memory_rel_Thunk_bits \\ strip_tac - \\ Cases_on `t'` \\ gvs [] + \\ rename [‘_ = SOME (Thunk has_been_eval a)’] + \\ Cases_on `has_been_eval` \\ gvs [] >- ( simp [asmTheory.word_cmp_def] \\ Cases_on `ret` \\ gvs [] @@ -293,25 +315,35 @@ Proof word_op_def, wordSemTheory.mem_load_def, wordSemTheory.set_var_def, wordSemTheory.get_vars_def] \\ simp [flush_state_def, wordSemTheory.flush_state_def] - \\ cheat) + \\ fs [state_rel_thm] \\ simp [join_env_def] + \\ conj_tac + >- + (irule backendPropsTheory.option_le_trans + \\ first_x_assum $ irule_at Any + \\ Cases_on ‘s.locals_size’ \\ fs [] + \\ Cases_on ‘stack_size t.stack’ \\ fs []) + \\ qpat_x_assum ‘_ t.mdomain _’ mp_tac + \\ match_mp_tac memory_rel_rearrange + \\ simp [SF DNF_ss]) \\ Cases_on `x''` \\ gvs [] \\ simp [wordSemTheory.evaluate_def, wordSemTheory.word_exp_def, wordSemTheory.get_var_def, lookup_insert, wordSemTheory.the_words_def, word_op_def, wordSemTheory.mem_load_def] \\ Cases_on `cut_env r s.locals` \\ gvs [] + \\ conj_tac >- (simp [set_var_def]) \\ simp [wordSemTheory.set_var_def, set_var_def] - \\ `state_rel c l1 l2 - (s with locals := insert q a x'') - (t with locals := insert (adjust_var q) - (t.memory (x' + bytes_in_word)) t.locals) - [] locs` suffices_by ( - rw [] \\ gvs [] - \\ gvs [state_rel_def, lookup_insert] - \\ asm_exists_tac \\ gvs [] - \\ gvs [inter_insert, domain_lookup, lookup_1_adjust_set, - lookup_3_adjust_set]) - \\ cheat) + \\ fs [state_rel_thm,lookup_insert,adjust_var_11] + \\ conj_tac >- (rw [] \\ gvs [cut_env_def,lookup_inter_alt] + \\ pop_assum mp_tac \\ rw [] \\ fs []) + \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] + \\ match_mp_tac memory_rel_insert + \\ fs[inter_insert_ODD_adjust_set_alt] + \\ qpat_x_assum ‘_ t.mdomain _’ mp_tac + \\ match_mp_tac memory_rel_rearrange + \\ simp [SF DNF_ss] + \\ rpt strip_tac + \\ drule_all MEM_join_env_cut_env \\ fs []) \\ IF_CASES_TAC \\ gvs [] >- gvs [asmTheory.word_cmp_def, dimword_def, good_dimindex_def] \\ IF_CASES_TAC \\ gvs [] @@ -344,6 +376,8 @@ Proof (lookup loc s.stack_frame_sizes) (dec_clock s))` \\ gvs [] \\ Cases_on `q` \\ gvs [] + \\ cheat (* + \\ drule_all state_rel_call_env_get_var \\ disch_then $ qspecl_then [`x' + bytes_in_word`, `lookup loc s.stack_frame_sizes`, @@ -359,7 +393,7 @@ Proof \\ IF_CASES_TAC \\ gvs [] \\ ntac 5 (TOP_CASE_TAC \\ gvs []) \\ simp [mk_loc_def] - \\ simp [GSYM wordSemTheory.set_var_def]) + \\ simp [GSYM wordSemTheory.set_var_def] *)) \\ Cases_on `x''` \\ gvs [] \\ simp [wordSemTheory.evaluate_def, wordSemTheory.get_vars_def, wordSemTheory.get_var_def, lookup_insert] @@ -388,7 +422,14 @@ Proof \\ first_x_assum $ qspec_then `n` assume_tac \\ gvs [] \\ Cases_on `lookup (adjust_var n) t.locals` \\ gvs []) \\ IF_CASES_TAC \\ gvs [] - >- cheat + >- + (fs [dataSemTheory.call_env_def,wordSemTheory.call_env_def] + \\ fs [dataSemTheory.push_env_def,wordSemTheory.push_env_def, + wordSemTheory.env_to_list_def, + wordSemTheory.stack_size_def,wordSemTheory.stack_size_frame_def, + dataSemTheory.dec_clock_def,dataSemTheory.size_of_stack_def, + dataSemTheory.size_of_stack_frame_def] + \\ cheat) \\ Cases_on `evaluate (q', call_env [RefPtr b n'; a] (lookup loc s.stack_frame_sizes) From 5a512e60effba6e51244ba2ac23513b7819bc731 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Mon, 29 Sep 2025 19:01:29 +0200 Subject: [PATCH 102/112] Reduce cheat count --- .../proofs/data_to_wordProofScript.sml | 103 +++++++----------- 1 file changed, 41 insertions(+), 62 deletions(-) diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml index dbf8a6e2d4..86f0670208 100644 --- a/compiler/backend/proofs/data_to_wordProofScript.sml +++ b/compiler/backend/proofs/data_to_wordProofScript.sml @@ -150,45 +150,6 @@ Proof \\ imp_res_tac IN_adjust_set_IN QED -(* -Theorem state_rel_call_env_get_var: - get_var src s.locals = SOME (RefPtr v0 ptr) /\ - get_var (adjust_var src) (t:('a,'c,'ffi) wordSem$state) = SOME w /\ - state_rel c l1 l2 s t [] locs ==> - state_rel c l1 l2 (call_env [RefPtr v0 ptr; a] ss (dec_clock s)) - (call_env [Loc l1 l2; w; t.memory w'] ss (dec_clock t)) [] locs -Proof - full_simp_tac(srw_ss())[state_rel_def,call_env_def,wordSemTheory.call_env_def,LET_THM, - dataSemTheory.dec_clock_def,wordSemTheory.dec_clock_def,lookup_adjust_var_fromList2] - \\ srw_tac[][lookup_fromList2,lookup_fromList] \\ srw_tac[][] - \\ imp_res_tac get_vars_IMP_LENGTH - \\ imp_res_tac wordPropsTheory.get_vars_length_lemma \\ full_simp_tac(srw_ss())[] - \\ imp_res_tac stack_rel_IMP_size_of_stack \\ fs [] - THEN1 - (Cases_on `s.stack_max` \\ fs [OPTION_MAP2_DEF] - \\ Cases_on `ss` \\ fs [OPTION_MAP2_DEF] - \\ Cases_on `size_of_stack s.stack` \\ fs [OPTION_MAP2_DEF] - \\ Cases_on `t.stack_max` \\ fs [OPTION_MAP2_DEF]) - THEN1 - (Cases_on `s.stack_max` \\ fs [OPTION_MAP2_DEF] - \\ Cases_on `ss` \\ fs [OPTION_MAP2_DEF] - \\ Cases_on `size_of_stack s.stack` \\ fs [OPTION_MAP2_DEF] - \\ Cases_on `t.stack_max` \\ fs [OPTION_MAP2_DEF]) - \\ asm_exists_tac - \\ full_simp_tac bool_ss [GSYM APPEND_ASSOC] - \\ imp_res_tac word_ml_inv_get_var_IMP - \\ first_assum (fn th => mp_tac th THEN match_mp_tac word_ml_inv_rearrange) - \\ full_simp_tac(srw_ss())[MEM] \\ srw_tac[][] \\ full_simp_tac(srw_ss())[] - \\ Cases_on `x` \\ full_simp_tac(srw_ss())[join_env_def,MEM_MAP,MEM_FILTER] - \\ Cases_on `y` \\ full_simp_tac(srw_ss())[MEM_toAList,lookup_inter_alt] \\ srw_tac[][MEM_ZIP] - \\ full_simp_tac(srw_ss())[lookup_fromList2,lookup_fromList] - \\ rpt disj1_tac - \\ Q.MATCH_ASSUM_RENAME_TAC `EVEN k` - \\ full_simp_tac(srw_ss())[DIV_LT_X] - \\ cheat -QED -*) - Theorem data_compile_correct: !prog s c n l l1 l2 res s1 (t:('a,'c,'ffi)wordSem$state) locs. (dataSem$evaluate (prog,s) = (res,s1)) /\ @@ -371,29 +332,47 @@ Proof \\ simp [wordSemTheory.add_ret_loc_def] \\ IF_CASES_TAC \\ gvs [] >- simp [wordSemTheory.flush_state_def] - \\ Cases_on - `evaluate (q', call_env [RefPtr b n'; a] - (lookup loc s.stack_frame_sizes) - (dec_clock s))` \\ gvs [] - \\ Cases_on `q` \\ gvs [] - \\ cheat (* - - \\ drule_all state_rel_call_env_get_var - \\ disch_then - $ qspecl_then [`x' + bytes_in_word`, `lookup loc s.stack_frame_sizes`, - `a`] assume_tac \\ gvs [] - \\ last_x_assum drule \\ simp [] - \\ disch_then $ qspecl_then [`loc`, `2`] assume_tac \\ gvs [] - \\ gvs [wordSemTheory.dec_clock_def] - \\ Cases_on `res1` \\ gvs [] - \\ Cases_on `x'''` \\ gvs [] - \\ Cases_on `x''` \\ gvs [] - \\ Cases_on `e` \\ gvs [] - \\ gvs [wordSemTheory.call_env_def, wordSemTheory.jump_exc_def] - \\ IF_CASES_TAC \\ gvs [] - \\ ntac 5 (TOP_CASE_TAC \\ gvs []) - \\ simp [mk_loc_def] - \\ simp [GSYM wordSemTheory.set_var_def] *)) + \\ gvs [CaseEq"prod",CaseEq"option",PULL_EXISTS] + \\ qmatch_goalsub_abbrev_tac ‘(FST _, t8)’ + \\ last_x_assum $ qspecl_then [‘c’,‘loc’,‘2’,‘l1’,‘l2’,‘t8’,‘locs’] mp_tac + \\ impl_tac >- + (fs [state_rel_thm,dataSemTheory.call_env_def, + dataSemTheory.dec_clock_def,wordSemTheory.dec_clock_def, + wordSemTheory.call_env_def,dec_clock_def,Abbr‘t8’] + \\ conj_tac >- EVAL_TAC + \\ conj_tac >- + (simp [fromList_def,fromList2_def] + \\ simp [lookup_insert] + \\ rw [] \\ gvs []) + \\ conj_tac >- + (Cases_on ‘t.stack_max’ \\ gvs [] + \\ Cases_on ‘stack_size t.stack’ \\ gvs [] + \\ Cases_on ‘lookup loc s.stack_frame_sizes’ \\ gvs [] ) + \\ conj_tac >- + (imp_res_tac stack_rel_IMP_size_of_stack + \\ Cases_on ‘size_of_stack s.stack’ \\ gvs [] + \\ Cases_on ‘lookup loc s.stack_frame_sizes’ \\ gvs [] + \\ Cases_on ‘s.stack_max’ \\ gvs [] + \\ Cases_on ‘t.stack_max’ \\ gvs []) + \\ qpat_x_assum ‘_ t.mdomain _’ mp_tac + \\ match_mp_tac memory_rel_rearrange + \\ simp [SF DNF_ss] + \\ EVAL_TAC + \\ simp [SF DNF_ss]) + \\ strip_tac \\ fs [] + \\ Cases_on ‘res1’ \\ gvs [] + \\ strip_tac \\ gvs [] + \\ CASE_TAC \\ gvs [] + \\ CASE_TAC \\ gvs [] + \\ ‘(jump_exc t8 = NONE ⇔ jump_exc t = NONE) ∧ + mk_loc (jump_exc t8) = mk_loc (jump_exc t) : 'a word_loc’ by + (gvs [wordSemTheory.jump_exc_def,Abbr‘t8’,wordSemTheory.call_env_def, + wordSemTheory.dec_clock_def,mk_loc_def] + \\ IF_CASES_TAC \\ simp [] + \\ rpt (CASE_TAC \\ gvs [mk_loc_def])) + \\ gvs [] + \\ Cases_on ‘jump_exc t’ \\ gvs [wordSemTheory.set_var_def]) + \\ Cases_on `x''` \\ gvs [] \\ simp [wordSemTheory.evaluate_def, wordSemTheory.get_vars_def, wordSemTheory.get_var_def, lookup_insert] From 5cdb6862cb265f5bb3be25bf44348b2098fbd40b Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Tue, 30 Sep 2025 11:01:11 +0200 Subject: [PATCH 103/112] Progress on Thunk cheats --- compiler/backend/data_to_wordScript.sml | 2 +- .../proofs/data_to_wordProofScript.sml | 101 +++++++++++++++--- .../proofs/data_to_word_gcProofScript.sml | 13 +++ 3 files changed, 99 insertions(+), 17 deletions(-) diff --git a/compiler/backend/data_to_wordScript.sml b/compiler/backend/data_to_wordScript.sml index 9d351e09b2..db2b0d0a0b 100644 --- a/compiler/backend/data_to_wordScript.sml +++ b/compiler/backend/data_to_wordScript.sml @@ -2449,7 +2449,7 @@ Definition force_thunk_def: [Assign 5 (Load (Op Add [Var 1; Const bytes_in_word])); (dtcase ret of | NONE => Call NONE (SOME loc) [0; adjust_var v1; 5] NONE - | SOME (r,ns) => Call (SOME ([r],adjust_sets ns,Skip,secn,l)) + | SOME (r,ns) => Call (SOME ([adjust_var r],adjust_sets ns,Skip,secn,l)) (SOME loc) [adjust_var v1; 5] NONE)])]),l+1) : 'a wordLang$prog # num End diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml index 86f0670208..5dfa2f7b17 100644 --- a/compiler/backend/proofs/data_to_wordProofScript.sml +++ b/compiler/backend/proofs/data_to_wordProofScript.sml @@ -150,6 +150,17 @@ Proof \\ imp_res_tac IN_adjust_set_IN QED +Theorem jump_exc_locals: + wordSem$jump_exc (t with locals := l) = jump_exc t +Proof + fs [wordSemTheory.jump_exc_def] +QED + +Theorem state_rel_cut_env_IMP_cut_env = + state_rel_cut_state_opt_SOME |> Q.GEN ‘args’ |> Q.SPEC ‘[]’ |> GEN_ALL + |> SRULE [get_vars_def,cut_state_opt_def,cut_state_def, + CaseEq"option",PULL_EXISTS,wordSemTheory.get_vars_def]; + Theorem data_compile_correct: !prog s c n l l1 l2 res s1 (t:('a,'c,'ffi)wordSem$state) locs. (dataSem$evaluate (prog,s) = (res,s1)) /\ @@ -179,7 +190,6 @@ Theorem data_compile_correct: | SOME (Rerr (Rabort(Rffi_error f))) => (res1 = SOME(FinalFFI f) /\ t1.ffi = s1.ffi) | SOME (Rerr (Rabort e)) => (res1 = SOME TimeOut) /\ t1.ffi = s1.ffi) Proof - recInduct dataSemTheory.evaluate_ind \\ rpt strip_tac \\ fs [] >~ [‘evaluate (Skip,s)’] >- (fs [comp_def,dataSemTheory.evaluate_def,wordSemTheory.evaluate_def] @@ -227,10 +237,7 @@ Proof \\ fs [cut_state_def,cut_env_def] \\ every_case_tac \\ fs [] \\ rw [] \\ fs [set_var_def]) >~ [‘evaluate (Force _ _ _,s)’] >- - - ( - - simp [comp_def, force_thunk_def] + (simp [comp_def, force_thunk_def] \\ TOP_CASE_TAC \\ gvs [] >- gvs [encode_header_def, encode_header_def, state_rel_def, good_dimindex_def, limits_inv_def, dimword_def, memory_rel_def, @@ -372,7 +379,6 @@ Proof \\ rpt (CASE_TAC \\ gvs [mk_loc_def])) \\ gvs [] \\ Cases_on ‘jump_exc t’ \\ gvs [wordSemTheory.set_var_def]) - \\ Cases_on `x''` \\ gvs [] \\ simp [wordSemTheory.evaluate_def, wordSemTheory.get_vars_def, wordSemTheory.get_var_def, lookup_insert] @@ -403,19 +409,82 @@ Proof \\ IF_CASES_TAC \\ gvs [] >- (fs [dataSemTheory.call_env_def,wordSemTheory.call_env_def] + \\ imp_res_tac stack_rel_IMP_size_of_stack \\ fs [dataSemTheory.push_env_def,wordSemTheory.push_env_def, - wordSemTheory.env_to_list_def, - wordSemTheory.stack_size_def,wordSemTheory.stack_size_frame_def, - dataSemTheory.dec_clock_def,dataSemTheory.size_of_stack_def, + wordSemTheory.env_to_list_def,dataSemTheory.dec_clock_def, + wordSemTheory.stack_size_def, + wordSemTheory.stack_size_frame_def, + dataSemTheory.size_of_stack_def, dataSemTheory.size_of_stack_frame_def] - \\ cheat) - \\ Cases_on - `evaluate (q', call_env [RefPtr b n'; a] - (lookup loc s.stack_frame_sizes) - (push_env (inter s.locals r) F (dec_clock s)))` + \\ fs [GSYM wordSemTheory.stack_size_def, + GSYM wordSemTheory.stack_size_frame_def, + GSYM dataSemTheory.size_of_stack_def, + GSYM dataSemTheory.size_of_stack_frame_def] + \\ Cases_on ‘s.stack_max’ \\ fs [] + \\ Cases_on ‘t.stack_max’ \\ fs [] + \\ Cases_on ‘s.locals_size’ \\ fs [] + \\ Cases_on ‘lookup loc s.stack_frame_sizes’ \\ fs [] + \\ Cases_on ‘size_of_stack s.stack’ \\ fs []) + \\ gvs [CaseEq"prod",CaseEq"option",PULL_EXISTS] + \\ qmatch_goalsub_abbrev_tac ‘(FST _, t8)’ + \\ last_x_assum $ qspecl_then [‘c’,‘loc’,‘2’,‘n’,‘l’,‘t8’,‘(l1,l2)::locs’] mp_tac + \\ impl_tac >- + (conj_tac >- (CCONTR_TAC \\ gvs []) + \\ reverse conj_tac >- gvs [Abbr‘t8’] + \\ simp [Abbr‘t8’] + \\ irule state_rel_call_env_push \\ simp [] + \\ conj_tac >- + (fs [cut_envs_adjust_sets_ODD] + \\ qexists_tac ‘r’ + \\ ‘cut_env r s.locals = SOME (inter s.locals r)’ by + simp [dataSemTheory.cut_env_def,SUBSET_DEF,domain_lookup] + \\ drule_all state_rel_cut_env_IMP_cut_env + \\ strip_tac \\ simp [] + \\ drule cut_env_IMP_cut_envs \\ strip_tac + \\ gvs [wordSemTheory.cut_envs_def,CaseEq"option"] + \\ gvs [wordSemTheory.cut_names_def,CaseEq"option"] + \\ simp [adjust_sets_def,adjust_set_def]) + \\ fs [state_rel_thm,lookup_insert] + \\ fs[inter_insert_ODD_adjust_set_alt] + \\ qpat_x_assum ‘_ t.mdomain _’ mp_tac + \\ match_mp_tac memory_rel_rearrange + \\ simp [SF DNF_ss]) + \\ strip_tac \\ fs [] + \\ Cases_on ‘res1’ + >- (gvs [] \\ gvs [AllCaseEqs()]) + \\ gvs [] + \\ rename [‘word_res = NotEnoughSpace ⇒ _’] + \\ Cases_on ‘word_res = NotEnoughSpace’ \\ gvs [] + >- (gvs [AllCaseEqs(),dataSemTheory.set_var_def,dataSemTheory.pop_env_def]) + \\ rename [‘dataSem$evaluate _ = (SOME data_res,s2)’] + \\ reverse $ Cases_on ‘data_res’ + >- ( + reverse (Cases_on `e`) \\ full_simp_tac(srw_ss())[] \\ srw_tac[][] + \\ full_simp_tac(srw_ss())[jump_exc_call_env,jump_exc_dec_clock, + jump_exc_push_env_NONE,Abbr‘t8’,jump_exc_locals] + THEN1 (every_case_tac \\ fs[]) + \\ Cases_on `jump_exc t = NONE` \\ full_simp_tac(srw_ss())[] + \\ full_simp_tac(srw_ss())[jump_exc_push_env_NONE_simp,jump_exc_locals] + \\ `LENGTH locs = LENGTH s.stack` by + (fs[state_rel_def] \\ imp_res_tac LIST_REL_LENGTH \\ fs[]) \\ full_simp_tac(srw_ss())[] + \\ `LENGTH s1.stack < LENGTH locs` by(imp_res_tac eval_exc_stack_shorter \\ fs[]) + \\ imp_res_tac LASTN_TL \\ full_simp_tac(srw_ss())[] + \\ fs [jump_exc_push_env_NONE] + \\ fs [wordSemTheory.set_var_def]) \\ gvs [] - \\ Cases_on `q` \\ gvs [] - \\ cheat) + \\ Cases_on ‘pop_env s2’ \\ gvs [] + \\ qrefinel [‘_’,‘NONE’] \\ simp [AllCaseEqs(),PULL_EXISTS] + \\ rename [‘set_var ret_var _ _’] + \\ drule_all state_rel_pop_env_set_var_IMP + \\ disch_then $ qspec_then ‘ret_var’ strip_assume_tac + \\ gvs [wordSemTheory.set_vars_def,alist_insert_def,wordSemTheory.set_var_def, + dataSemTheory.set_var_def] + \\ reverse $ rpt strip_tac + >- (imp_res_tac dataPropsTheory.pop_env_const + \\ imp_res_tac wordPropsTheory.pop_env_const + \\ gvs []) + \\ simp [Abbr‘t8’] + \\ drule evaluate_IMP_domain_EQ \\ fs []) >~ [‘evaluate (Tick,s)’] >- (fs [comp_def,dataSemTheory.evaluate_def,wordSemTheory.evaluate_def] \\ `t.clock = s.clock` by fs [state_rel_def] \\ fs [] \\ srw_tac[][] diff --git a/compiler/backend/proofs/data_to_word_gcProofScript.sml b/compiler/backend/proofs/data_to_word_gcProofScript.sml index 8aec2303ce..5120cc7267 100644 --- a/compiler/backend/proofs/data_to_word_gcProofScript.sml +++ b/compiler/backend/proofs/data_to_word_gcProofScript.sml @@ -5357,6 +5357,19 @@ QED val _ = temp_delsimps ["fromAList_def"] +Theorem state_rel_call_env_push: + state_rel c l1 l2 s t (ZIP(xs,ws)) locs ∧ + LENGTH xs = LENGTH ws ∧ + cut_env r s.locals = SOME x ∧ + cut_envs (adjust_sets r) t.locals = SOME y ⇒ + state_rel c q l + (call_env xs ss (push_env x F (dec_clock s))) + (call_env (Loc q l::ws) ss (push_env y NONE (dec_clock t))) [] + ((l1,l2)::locs) +Proof + cheat (* state_rel_call_env_push_env *) +QED + Theorem state_rel_call_env_push_env: (* TODO: tidy up proof *) !opt:(num # 'a wordLang$prog # num # num) option. state_rel c l1 l2 s (t:('a,'c,'ffi)wordSem$state) [] locs /\ From 4fec08ea6778059db41b94c36284d58a95867530 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Tue, 30 Sep 2025 15:50:29 +0300 Subject: [PATCH 104/112] Update candle proofs for changes in Force semantics --- .../prover/candle_prover_evaluateScript.sml | 134 ++++++++++++------ candle/prover/permsScript.sml | 61 +++++--- 2 files changed, 131 insertions(+), 64 deletions(-) diff --git a/candle/prover/candle_prover_evaluateScript.sml b/candle/prover/candle_prover_evaluateScript.sml index c5d2d2cfb0..974479579e 100644 --- a/candle/prover/candle_prover_evaluateScript.sml +++ b/candle/prover/candle_prover_evaluateScript.sml @@ -658,7 +658,7 @@ Proof \\ irule kernel_loc_ok_LUPDATE1 \\ rpt strip_tac \\ gs []) \\ Cases_on ‘op = ThunkOp ForceThunk’ \\ gs[] - >- (rw [do_app_cases] \\ gs [thunk_op_def]) + >- (rw [do_app_cases] \\ gs [thunk_op_def, AllCaseEqs()]) \\ Cases_on ‘op’ \\ gs [] \\ Cases_on ‘t’ \\ gs [] QED @@ -666,8 +666,7 @@ QED Theorem state_ok_dest_thunk: state_ok ctxt s ∧ EVERY (v_ok ctxt) vs ∧ - dest_thunk vs s.refs = IsThunk m v ⇒ - v_ok ctxt v ∧ env_ok ctxt (sing_env n v) + dest_thunk (REVERSE vs) s.refs = IsThunk m v ⇒ v_ok ctxt v Proof rw [] >- ( @@ -687,7 +686,7 @@ Theorem state_ok_update_thunk: state_ok ctxt s ∧ EVERY (v_ok ctxt) vs ∧ EVERY (v_ok ctxt) vs2 ∧ - update_thunk vs s.refs vs2 = SOME refs ⇒ + update_thunk (REVERSE vs) s.refs vs2 = SOME refs ⇒ state_ok ctxt (s with refs := refs) Proof rw [] @@ -708,50 +707,103 @@ Proof >~ [‘EvalOp’] >- (Cases_on ‘op’ \\ gs[] \\ Cases_on ‘t’ \\ gs[]) >~ [‘FunApp’] >- (Cases_on ‘op’ \\ gs[] \\ Cases_on ‘t’ \\ gs[]) >~ [‘Force’] >- ( - gvs [AllCaseEqs()] + Cases_on ‘op’ \\ gvs [] \\ Cases_on ‘t’ \\ gvs [] + \\ qpat_x_assum ‘_ = (s',res)’ mp_tac + \\ TOP_CASE_TAC \\ gvs [] + \\ last_x_assum drule_all \\ strip_tac + \\ reverse TOP_CASE_TAC \\ gvs [] + >- ( + rw [] \\ gvs [] + \\ goal_assum drule \\ gvs []) + \\ TOP_CASE_TAC \\ gvs [] >~ [‘BadRef’] >- ( - first_x_assum (drule_all_then strip_assume_tac) \\ gvs [state_ok_def]) + rw [] \\ gvs [] + \\ goal_assum drule \\ gvs [state_ok_def]) >~ [‘NotThunk’] >- ( - first_x_assum (drule_all_then strip_assume_tac) \\ gvs [state_ok_def]) - >~ [‘IsThunk NotEvaluated _’, ‘s'.clock = 0’] >- ( - first_x_assum (drule_all_then strip_assume_tac) \\ gvs [state_ok_def]) + rw [] \\ gvs [] + \\ goal_assum drule \\ gvs [state_ok_def]) + \\ TOP_CASE_TAC \\ gvs [] >- ( - first_x_assum (drule_all_then strip_assume_tac) \\ gvs [] + rw [] \\ gvs [] \\ goal_assum drule \\ gvs [] - \\ drule_all state_ok_dest_thunk \\ rw []) + \\ drule_all_then assume_tac state_ok_dest_thunk \\ gvs []) + \\ TOP_CASE_TAC \\ gvs [] >- ( - first_x_assum (drule_all_then strip_assume_tac) \\ gvs [] - \\ goal_assum drule \\ gvs [] - \\ rename1 ‘state_ok ctxt1 st'’ - \\ ‘state_ok ctxt1 (dec_clock st')’ by ( - gvs [state_ok_def, dec_clock_def] \\ metis_tac []) - \\ last_x_assum drule - \\ impl_tac \\ rw [] - >- (drule_all state_ok_dest_thunk \\ rw []) - >- gvs [AppUnit_def, safe_exp_def] - >- gvs [state_ok_def]) + rw [] \\ gvs [] + \\ goal_assum drule \\ gvs [state_ok_def]) + \\ ntac 2 (TOP_CASE_TAC \\ gvs []) + >- ( + rw [] \\ gvs [] + \\ goal_assum drule \\ gvs [state_ok_def]) + \\ TOP_CASE_TAC \\ gvs [] + \\ ‘state_ok ctxt' (dec_clock q)’ + by (gvs [dec_clock_def, state_ok_def] \\ metis_tac []) + \\ Cases_on ‘kernel_vals ctxt' v’ + >- ( + drule (INST_TYPE [“:'a”|->“:'ffi”] kernel_vals_ok) + \\ ‘v_ok ctxt' (Conv NONE [])’ by gvs [v_ok_def] + \\ disch_then (drule_all_then (strip_assume_tac)) \\ gs [] + >- ( + rw [] \\ gvs [] + \\ goal_assum drule \\ gvs [state_ok_def]) + \\ rpt (TOP_CASE_TAC \\ gvs []) + >- ( + rw [] \\ gvs [] + \\ goal_assum drule \\ gvs [state_ok_def]) + >- ( + rw [] \\ gvs [] + \\ qexists ‘ctxt''’ \\ gvs [] + \\ drule_at (Pat ‘update_thunk _ _ _ = _’) state_ok_update_thunk + \\ disch_then $ qspec_then ‘ctxt''’ mp_tac + \\ impl_tac \\ gvs [] + \\ gvs [EVERY_EL]) + >- ( + rw [] \\ gvs [] + \\ qexists ‘ctxt''’ \\ gvs []) + \\ rw [] \\ gvs [] + \\ qexists ‘ctxt''’ \\ gvs [state_ok_def]) + \\ first_x_assum drule + \\ impl_tac >- ( + gvs [do_opapp_cases] + >~ [‘Closure env1 n e’] >- ( + drule_all state_ok_dest_thunk \\ strip_tac + \\ gvs [v_ok_def] + \\ irule env_ok_with_nsBind \\ gvs [v_ok_def] + \\ ‘env1 with c := env1.c = env1’ by simp [sem_env_component_equality] + \\ gvs []) + \\ drule_all state_ok_dest_thunk \\ strip_tac + \\ gvs [v_ok_def] + \\ gs [env_ok_def, evaluateTheory.dec_clock_def, find_recfun_ALOOKUP, + SF SFY_ss] + \\ drule_then assume_tac ALOOKUP_MEM + \\ gs [EVERY_MEM, EVERY_MAP, FORALL_PROD, SF SFY_ss] + \\ Cases \\ simp [build_rec_env_merge, ml_progTheory.nsLookup_nsBind_compute] + \\ rw [] \\ gs [] + \\ gs [nsLookup_nsAppend_some, nsLookup_alist_to_ns_some, + nsLookup_alist_to_ns_none] + >- simp [v_ok_def] + >~ [‘ALOOKUP _ _ = SOME _’] >- ( + drule_then assume_tac ALOOKUP_MEM + \\ gvs [MEM_MAP, EXISTS_PROD, v_ok_def, EVERY_MEM] + \\ rw [DISJ_EQ_IMP, env_ok_def] \\ gs [SF SFY_ss]) + \\ first_x_assum irule + \\ gs [SF SFY_ss]) + \\ strip_tac \\ gvs [] + \\ reverse TOP_CASE_TAC \\ gvs [] >- ( - first_x_assum (drule_all_then strip_assume_tac) \\ gvs [] - \\ rename1 ‘state_ok ctxt1 st'’ - \\ ‘state_ok ctxt1 (dec_clock st')’ by ( - gvs [state_ok_def, dec_clock_def] \\ metis_tac []) - \\ last_x_assum drule - \\ impl_tac \\ rw [] - >- (drule_all state_ok_dest_thunk \\ rw []) - >- gvs [AppUnit_def, safe_exp_def] - \\ qexists ‘ctxt''’ \\ gvs [] - \\ ‘EVERY (v_ok ctxt'') vs’ by gvs [EVERY_EL] - \\ drule_all state_ok_update_thunk \\ rw []) + rw [] \\ gvs [] + \\ goal_assum $ drule_at (Pos $ el 2) + \\ rw [] \\ gvs []) + \\ TOP_CASE_TAC \\ gvs [] >- ( - first_x_assum (drule_all_then strip_assume_tac) \\ gvs [] - \\ rename1 ‘state_ok ctxt1 st'’ - \\ ‘state_ok ctxt1 (dec_clock st')’ by ( - gvs [state_ok_def, dec_clock_def] \\ metis_tac []) - \\ last_x_assum drule - \\ impl_tac \\ rw [] - >- (drule_all state_ok_dest_thunk \\ rw []) - >- gvs [AppUnit_def, safe_exp_def] - >- metis_tac [])) + rw [] \\ gvs [] + \\ goal_assum drule \\ gvs [state_ok_def]) + \\ strip_tac \\ gvs [] + \\ goal_assum $ drule_at (Pos $ el 3) \\ gvs [] + \\ drule_at (Pat ‘update_thunk _ _ _ = _’) state_ok_update_thunk \\ gvs [] + \\ disch_then drule \\ gvs [] + \\ impl_tac \\ gvs [] + \\ gvs [EVERY_EL]) >~ [‘Simple’] >- ( gvs [AllCaseEqs()] \\ first_x_assum (drule_all_then strip_assume_tac) \\ gs [state_ok_def] diff --git a/candle/prover/permsScript.sml b/candle/prover/permsScript.sml index 89f1284e26..0f318dd685 100644 --- a/candle/prover/permsScript.sml +++ b/candle/prover/permsScript.sml @@ -574,7 +574,7 @@ Proof \\ gvs [perms_ok_def, store_assign_def] \\ rw [EL_LUPDATE, perms_ok_ref_def]) \\ Cases_on ‘op = ThunkOp ForceThunk’ \\ gs[] - >- (rw [do_app_cases] \\ gvs [thunk_op_def]) + >- (rw [do_app_cases] \\ gvs [thunk_op_def, AllCaseEqs()]) \\ Cases_on ‘op’ \\ gs [] \\ Cases_on ‘t’ \\ gs [] QED @@ -721,11 +721,8 @@ Proof perms_ok_state_def] \\ last_x_assum drule \\ rw [] \\ gvs [perms_ok_def, perms_ok_ref_def]) \\ ( - gvs [AppUnit_def, sing_env_def, perms_ok_env_def, dec_clock_def, - namespaceTheory.nsEmpty_def, namespaceTheory.nsBind_def] + gvs [dec_clock_def] \\ gvs [oneline dest_thunk_def, AllCaseEqs(), store_lookup_def] - \\ gvs [evaluate_def, do_con_check_def, build_conv_def, - namespaceTheory.nsLookup_def, AllCaseEqs()] \\ gvs [do_opapp_cases] >- ((* Closure *) last_x_assum mp_tac @@ -736,14 +733,13 @@ Proof perms_ok_state_def, EL_LUPDATE] \\ rw [] \\ gvs [perms_ok_ref_def] \\ first_x_assum (drule_then assume_tac) \\ gs []) - \\ gs [SF DNF_ss, perms_ok_env_def, perms_ok_def, find_recfun_ALOOKUP, - EVERY_MEM, MEM_MAP, PULL_EXISTS, perms_ok_state_def] - \\ rw [] \\ gs [] - \\ ( - first_x_assum (drule_then assume_tac) - \\ gvs [perms_ok_ref_def, perms_ok_def, perms_ok_env_def] - \\ first_x_assum irule \\ gvs [] - \\ metis_tac [])) + \\ gvs [perms_ok_state_def] + \\ first_x_assum (drule_then assume_tac) \\ gvs [] + \\ gvs [perms_ok_ref_def, perms_ok_def, perms_ok_env_def] + \\ Cases \\ simp [nsLookup_nsBind_compute] + \\ rw [] \\ gvs [perms_ok_def] + \\ first_x_assum irule + \\ first_x_assum (irule_at Any) \\ gvs []) >- ((* Recclosure *) last_x_assum mp_tac \\ reverse impl_tac @@ -753,20 +749,39 @@ Proof perms_ok_state_def, EL_LUPDATE] \\ rw [] \\ gvs [perms_ok_ref_def] \\ first_x_assum (drule_then assume_tac) \\ gs []) - \\ gs [SF DNF_ss, perms_ok_env_def, perms_ok_def, find_recfun_ALOOKUP, - EVERY_MEM, MEM_MAP, PULL_EXISTS, perms_ok_state_def] + \\ gvs [perms_ok_state_def] + \\ first_x_assum (drule_then assume_tac) \\ gvs [] + \\ gvs [perms_ok_ref_def, perms_ok_def, perms_ok_env_def] + \\ gvs [SF DNF_ss, find_recfun_ALOOKUP, EVERY_MEM, MEM_MAP, + PULL_EXISTS] \\ drule_then assume_tac ALOOKUP_MEM \\ qmatch_asmsub_abbrev_tac ‘MEM yyy funs’ - \\ first_x_assum drule \\ simp_tac std_ss [Abbr ‘yyy’] + \\ first_assum drule \\ simp_tac std_ss [Abbr ‘yyy’] + \\ strip_tac + \\ simp [build_rec_env_merge] + \\ Cases \\ simp [nsLookup_nsBind_compute] \\ rw [] \\ gs [nsLookup_nsAppend_some, nsLookup_alist_to_ns_some, nsLookup_alist_to_ns_none] - >- ( - gvs [perms_ok_ref_def, perms_ok_def, perms_ok_env_def] - \\ first_x_assum irule \\ gvs [] - \\ gvs [PULL_EXISTS, MEM_MAP, EVERY_MAP] - \\ metis_tac []) - >- gvs [perms_ok_ref_def, perms_ok_def, EVERY_MAP, EVERY_EL, - MEM_EL]))) + >- gvs [perms_ok_def] + >~ [‘ALOOKUP _ _ = NONE’] >- ( + first_x_assum irule + \\ first_assum (irule_at Any) + \\ gs [ALOOKUP_NONE, MAP_MAP_o, o_DEF, LAMBDA_PROD, MEM_MAP, + EXISTS_PROD] + \\ first_assum (irule_at Any) + \\ first_assum (irule_at Any) \\ gs [] + \\ strip_tac \\ gvs []) + >~ [‘ALOOKUP _ _ = SOME _’] >- ( + drule_then assume_tac ALOOKUP_MEM + \\ gs [MEM_MAP, EXISTS_PROD, perms_ok_def, EVERY_MAP, EVERY_MEM] + \\ gs [perms_ok_env_def, MEM_MAP, EXISTS_PROD] + \\ rw [] \\ gs [FORALL_PROD, SF SFY_ss]) + \\ first_x_assum irule + \\ first_assum (irule_at Any) + \\ gs [ALOOKUP_NONE, MAP_MAP_o, o_DEF, LAMBDA_PROD, MEM_MAP, + EXISTS_PROD] + \\ first_assum (irule_at Any) + \\ first_assum (irule_at Any) \\ gs []))) \\ gvs [AllCaseEqs()] \\ gvs [evaluate_def] \\ Cases_on ‘op = Opapp’ \\ gs [] From 27d1c571b1131f89e9f2d1895e60e7b08db29007 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Thu, 25 Sep 2025 02:01:44 +0300 Subject: [PATCH 105/112] Update for change in name of while theory --- basis/fsFFIPropsScript.sml | 2 +- basis/pure/mlstringScript.sml | 4 +-- .../syntax/holSyntaxExtraScript.sml | 2 +- candle/overloading/syntax/holSyntaxScript.sml | 2 +- candle/standard/syntax/holSyntaxScript.sml | 2 +- characteristic/cfDivScript.sml | 4 +-- compiler/backend/ag32/ag32_memoryScript.sml | 32 +++++++++---------- .../ag32/proofs/ag32_basis_ffiProofScript.sml | 6 ++-- .../ag32/proofs/ag32_ffi_codeProofScript.sml | 8 ++--- .../backend/proofs/bvl_to_bviProofScript.sml | 16 +++++----- .../backend/proofs/clos_to_bvlProofScript.sml | 4 +-- .../proofs/data_to_wordProofScript.sml | 2 +- .../proofs/data_to_word_assignProofScript.sml | 2 +- .../proofs/data_to_word_gcProofScript.sml | 2 +- .../proofs/data_to_word_memoryProofScript.sml | 2 +- .../proofs/flat_to_closProofScript.sml | 2 +- .../proofs/lab_to_targetProofScript.sml | 2 +- .../backend/proofs/source_evalProofScript.sml | 10 +++--- compiler/backend/reg_alloc/parmoveScript.sml | 6 ++-- compiler/inference/unifyScript.sml | 24 +++++++------- examples/filterProgScript.sml | 4 +-- misc/miscScript.sml | 4 +-- pancake/semantics/panItreeSemScript.sml | 2 +- translator/std_preludeScript.sml | 2 +- 24 files changed, 73 insertions(+), 73 deletions(-) diff --git a/basis/fsFFIPropsScript.sml b/basis/fsFFIPropsScript.sml index ff83e0285b..aa23fcc1a7 100644 --- a/basis/fsFFIPropsScript.sml +++ b/basis/fsFFIPropsScript.sml @@ -150,7 +150,7 @@ Proof fs [validFD_def,nextFD_def] \\ qabbrev_tac `xs = MAP FST fs.infds` \\ match_mp_tac (SIMP_RULE std_ss [] - (Q.ISPEC `\n:num. ~MEM n xs` whileTheory.LEAST_INTRO)) + (Q.ISPEC `\n:num. ~MEM n xs` WhileTheory.LEAST_INTRO)) \\ qexists_tac `SUM xs + 1` \\ strip_tac \\ qsuff_tac `!xs m:num. MEM m xs ==> m <= SUM xs` diff --git a/basis/pure/mlstringScript.sml b/basis/pure/mlstringScript.sml index 17a2f2d5e8..4910d25f84 100644 --- a/basis/pure/mlstringScript.sml +++ b/basis/pure/mlstringScript.sml @@ -749,10 +749,10 @@ Theorem OLEAST_LE_STEP: else (OLEAST j. i + 1 <= j /\ P j)) Proof rw [] - \\ simp [whileTheory.OLEAST_EQ_SOME] + \\ simp [WhileTheory.OLEAST_EQ_SOME] \\ qmatch_goalsub_abbrev_tac `opt1 = $OLEAST _` \\ Cases_on `opt1` - \\ fs [whileTheory.OLEAST_EQ_SOME] + \\ fs [WhileTheory.OLEAST_EQ_SOME] \\ rw [] \\ fs [LESS_EQ |> REWRITE_RULE [ADD1] |> GSYM, arithmeticTheory.LT_LE] \\ CCONTR_TAC diff --git a/candle/overloading/syntax/holSyntaxExtraScript.sml b/candle/overloading/syntax/holSyntaxExtraScript.sml index 3d23e03072..ebd32aeffd 100644 --- a/candle/overloading/syntax/holSyntaxExtraScript.sml +++ b/candle/overloading/syntax/holSyntaxExtraScript.sml @@ -12996,7 +12996,7 @@ Proof rw[] >> last_x_assum(qspec_then `f` mp_tac) >> disch_then assume_tac >> - pop_assum(mp_tac o Ho_Rewrite.REWRITE_RULE[whileTheory.LEAST_EXISTS]) >> + pop_assum(mp_tac o Ho_Rewrite.REWRITE_RULE[WhileTheory.LEAST_EXISTS]) >> rename1 `f n` >> rpt strip_tac >> reverse(Cases_on `R' (f n) (f (SUC n))`) >- goal_assum drule >> diff --git a/candle/overloading/syntax/holSyntaxScript.sml b/candle/overloading/syntax/holSyntaxScript.sml index 6782da328f..3cf4d8d524 100644 --- a/candle/overloading/syntax/holSyntaxScript.sml +++ b/candle/overloading/syntax/holSyntaxScript.sml @@ -298,7 +298,7 @@ QED Theorem LEAST_EXISTS[local]: (∃n:num. P n) ⇒ ∃k. P k ∧ ∀m. m < k ⇒ ¬(P m) Proof - metis_tac[whileTheory.LEAST_EXISTS] + metis_tac[WhileTheory.LEAST_EXISTS] QED val VARIANT_PRIMES_def = new_specification diff --git a/candle/standard/syntax/holSyntaxScript.sml b/candle/standard/syntax/holSyntaxScript.sml index 2974f4f49a..f6dfb9bcf2 100644 --- a/candle/standard/syntax/holSyntaxScript.sml +++ b/candle/standard/syntax/holSyntaxScript.sml @@ -271,7 +271,7 @@ QED Triviality LEAST_EXISTS: (∃n:num. P n) ⇒ ∃k. P k ∧ ∀m. m < k ⇒ ¬(P m) Proof - metis_tac[whileTheory.LEAST_EXISTS] + metis_tac[WhileTheory.LEAST_EXISTS] QED val VARIANT_PRIMES_def = new_specification diff --git a/characteristic/cfDivScript.sml b/characteristic/cfDivScript.sml index cfd59a49c0..8c41138d93 100644 --- a/characteristic/cfDivScript.sml +++ b/characteristic/cfDivScript.sml @@ -4420,7 +4420,7 @@ Proof \\ rw[] \\ `LFLATTEN(LGENLIST f NONE) <> [||]` by(CCONTR_TAC >> fs[]) \\ dxrule LFLATTEN_NOT_NIL_IMP - \\ disch_then(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[whileTheory.LEAST_EXISTS]) + \\ disch_then(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[WhileTheory.LEAST_EXISTS]) \\ qmatch_asmsub_abbrev_tac `LNTH a1` \\ Q.ISPECL_THEN [`a1`,`f`] assume_tac (GEN_ALL LGENLIST_CHUNK_GENLIST) \\ fs[] @@ -4720,7 +4720,7 @@ Proof (fs[Once LFLATTEN]) \\ match_mp_tac OR_INTRO_THM2 \\ pop_assum(assume_tac o Ho_Rewrite.REWRITE_RULE [every_LGENLIST,o_DEF,NOT_FORALL_THM]) - \\ pop_assum(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[whileTheory.LEAST_EXISTS]) + \\ pop_assum(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[WhileTheory.LEAST_EXISTS]) \\ fs[CONV_RULE(LHS_CONV SYM_CONV) fromList_EQ_LNIL] \\ qspecl_then [`LEAST x. events (n + x) <> []`,`fromList o events o $+ n`] mp_tac (LGENLIST_CHUNK_GENLIST diff --git a/compiler/backend/ag32/ag32_memoryScript.sml b/compiler/backend/ag32/ag32_memoryScript.sml index f559759f99..8382b62b87 100644 --- a/compiler/backend/ag32/ag32_memoryScript.sml +++ b/compiler/backend/ag32/ag32_memoryScript.sml @@ -876,7 +876,7 @@ Theorem ag32_ffi_get_arg_length_loop1_thm: ((4w =+ s.R 4w + n2w (n+1)) ((5w =+ s.R 5w + n2w (n+1)) s.R))) |> Proof - reverse(rw[whileTheory.OLEAST_def]) + reverse(rw[WhileTheory.OLEAST_def]) >- ( rw[Once ag32_ffi_get_arg_length_loop1_def] \\ fs[] \\ metis_tac[] ) @@ -987,7 +987,7 @@ Proof \\ simp[Once get_next_mem_arg_def] \\ Cases_on`m a = 0w` \\ fs[] >- ( - simp[whileTheory.OLEAST_def] + simp[WhileTheory.OLEAST_def] \\ IF_CASES_TAC \\ fs[] \\ numLib.LEAST_ELIM_TAC \\ conj_tac >- metis_tac[] @@ -996,9 +996,9 @@ Proof \\ first_x_assum(qspec_then`0`mp_tac) \\ simp[] ) \\ IF_CASES_TAC - >- ( simp[whileTheory.OLEAST_def] ) + >- ( simp[WhileTheory.OLEAST_def] ) \\ fs[] - \\ simp[whileTheory.OLEAST_def] + \\ simp[WhileTheory.OLEAST_def] \\ reverse IF_CASES_TAC \\ fs[] >- ( Cases_on`n` \\ fs[] @@ -1053,7 +1053,7 @@ Proof ag32Theory.dfn'JumpIfNotZero_def, ag32_ffi_get_arg_length_loop1_thm, APPLY_UPDATE_THM] \\ CASE_TAC \\ simp[APPLY_UPDATE_THM] - \\ fs[whileTheory.OLEAST_def] + \\ fs[WhileTheory.OLEAST_def] \\ simp[Once ag32_ffi_get_arg_length_loop_def, APPLY_UPDATE_THM] \\ simp[ag32Theory.dfn'JumpIfZero_def, ag32Theory.incPC_def, ag32Theory.ri2word_def, ag32Theory.ALU_def, APPLY_UPDATE_THM] @@ -1068,7 +1068,7 @@ Proof \\ rw[] \\ fs[] \\ AP_THM_TAC \\ AP_TERM_TAC \\ AP_THM_TAC \\ AP_TERM_TAC - \\ simp[get_next_mem_arg_LEAST, whileTheory.OLEAST_def] + \\ simp[get_next_mem_arg_LEAST, WhileTheory.OLEAST_def] \\ IF_CASES_TAC \\ fs[]) \\ rw[] \\ simp[Once ag32_ffi_get_arg_length_loop_def] @@ -1078,7 +1078,7 @@ Proof ag32Theory.dfn'JumpIfNotZero_def, ag32_ffi_get_arg_length_loop1_thm, APPLY_UPDATE_THM] \\ CASE_TAC \\ simp[APPLY_UPDATE_THM] - \\ fs[whileTheory.OLEAST_def] + \\ fs[WhileTheory.OLEAST_def] \\ qmatch_goalsub_abbrev_tac`ag32_ffi_get_arg_length_loop s'` \\ first_x_assum(qspec_then`s'`mp_tac) \\ simp[Abbr`s'`, APPLY_UPDATE_THM, ADD1, GSYM word_add_n2w] @@ -1106,7 +1106,7 @@ Proof \\ simp[get_mem_arg_def, GSYM ADD1, UNCURRY] \\ AP_TERM_TAC \\ AP_TERM_TAC - \\ simp[get_next_mem_arg_LEAST, whileTheory.OLEAST_def] + \\ simp[get_next_mem_arg_LEAST, WhileTheory.OLEAST_def] \\ IF_CASES_TAC \\ fs[] QED @@ -1294,7 +1294,7 @@ Theorem ag32_ffi_get_arg_find1_thm: R := ((8w =+ 0w) ((5w =+ s.R 5w + n2w (n+1)) s.R)) |> Proof - reverse(rw[whileTheory.OLEAST_def]) + reverse(rw[WhileTheory.OLEAST_def]) >- ( rw[Once ag32_ffi_get_arg_find1_def] \\ fs[] \\ metis_tac[] ) @@ -1400,7 +1400,7 @@ Proof ag32Theory.incPC_def, ag32Theory.ALU_def, ag32Theory.dfn'JumpIfZero_def, ag32Theory.dfn'JumpIfNotZero_def, ag32_ffi_get_arg_find1_thm, APPLY_UPDATE_THM] - \\ CASE_TAC \\ simp[APPLY_UPDATE_THM] \\ fs[whileTheory.OLEAST_def] + \\ CASE_TAC \\ simp[APPLY_UPDATE_THM] \\ fs[WhileTheory.OLEAST_def] \\ qmatch_goalsub_abbrev_tac`ag32_ffi_get_arg_find s'` \\ first_x_assum(qspec_then`s'`mp_tac) \\ simp[Abbr`s'`, APPLY_UPDATE_THM, ADD1, GSYM word_add_n2w] @@ -1430,12 +1430,12 @@ Proof rw[] \\ rw[get_mem_arg_def] \\ rw[get_next_mem_arg_LEAST] - \\ rw[whileTheory.OLEAST_def] + \\ rw[WhileTheory.OLEAST_def] \\ fs[] ) \\ rw[] \\ fs[] \\ Cases_on`index` \\ fs[get_mem_arg_def] \\ simp[UNCURRY] - \\ simp[get_next_mem_arg_LEAST, whileTheory.OLEAST_def] + \\ simp[get_next_mem_arg_LEAST, WhileTheory.OLEAST_def] \\ IF_CASES_TAC \\ fs[] QED @@ -1511,7 +1511,7 @@ Proof \\ Induct_on`n` \\ rw[] >- ( simp[Once ag32_ffi_get_arg_store_def] - \\ fs[whileTheory.OLEAST_def] + \\ fs[WhileTheory.OLEAST_def] \\ qpat_x_assum`_ = 0n`mp_tac \\ numLib.LEAST_ELIM_TAC \\ conj_tac >- metis_tac[] @@ -1537,7 +1537,7 @@ Proof \\ simp[Once ag32_ffi_get_arg_store_def] \\ IF_CASES_TAC >- ( - fs[whileTheory.OLEAST_def] + fs[WhileTheory.OLEAST_def] \\ first_assum(qspec_then`n'`mp_tac) \\ simp_tac(srw_ss())[DISJ_EQ_IMP] \\ impl_tac >- fs[] \\ strip_tac @@ -1571,7 +1571,7 @@ Proof \\ disch_then(qspec_then`n'`mp_tac) \\ strip_tac \\ fs[] \\ fs[bitTheory.BITS_ZERO3, NOT_LESS_EQUAL, DISJ_EQ_IMP] \\ rw[] - \\ fs[whileTheory.OLEAST_def] + \\ fs[WhileTheory.OLEAST_def] \\ qpat_x_assum`_ = SUC _`mp_tac \\ numLib.LEAST_ELIM_TAC \\ conj_tac >- metis_tac[] @@ -1580,7 +1580,7 @@ Proof \\ simp[] ) \\ qmatch_goalsub_abbrev_tac`ag32_ffi_get_arg_store s'` \\ last_x_assum(qspec_then`s'`mp_tac) - \\ fs[whileTheory.OLEAST_def] + \\ fs[WhileTheory.OLEAST_def] \\ qpat_x_assum`_ = SUC _`mp_tac \\ numLib.LEAST_ELIM_TAC \\ conj_tac >- metis_tac[] diff --git a/compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml b/compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml index 1c90aeca10..08a5c2a831 100644 --- a/compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml +++ b/compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml @@ -2147,7 +2147,7 @@ Proof >- ( rw[bytes_in_memory_APPEND] \\ rw[get_next_mem_arg_LEAST] - \\ simp[whileTheory.OLEAST_def] + \\ simp[WhileTheory.OLEAST_def] \\ reverse IF_CASES_TAC >- ( fs[SNOC_APPEND, bytes_in_memory_APPEND, bytes_in_memory_def] ) \\ simp[] @@ -2169,7 +2169,7 @@ Proof \\ first_x_assum drule \\ disch_then drule \\ rw[] - \\ simp[get_next_mem_arg_LEAST, whileTheory.OLEAST_def] + \\ simp[get_next_mem_arg_LEAST, WhileTheory.OLEAST_def] \\ reverse IF_CASES_TAC >- ( fs[SNOC_APPEND, bytes_in_memory_APPEND, bytes_in_memory_def] ) \\ simp[] @@ -2403,7 +2403,7 @@ Proof \\ qpat_x_assum`a' = a`SUBST_ALL_TAC \\ qpat_x_assum`a = _`(assume_tac o SYM) \\ simp[Abbr`s1`, APPLY_UPDATE_THM] - \\ simp[whileTheory.OLEAST_def] + \\ simp[WhileTheory.OLEAST_def] \\ simp[GSYM CONJ_ASSOC] \\ conj_asm1_tac >- ( diff --git a/compiler/backend/ag32/proofs/ag32_ffi_codeProofScript.sml b/compiler/backend/ag32/proofs/ag32_ffi_codeProofScript.sml index 4f300345e9..0fdab920d6 100644 --- a/compiler/backend/ag32/proofs/ag32_ffi_codeProofScript.sml +++ b/compiler/backend/ag32/proofs/ag32_ffi_codeProofScript.sml @@ -3045,7 +3045,7 @@ Proof Q.REFINE_EXISTS_TAC ‘k + k2’ >> simp0[FUNPOW_ADD] >> simp0[Once LET_THM] >> rev_full_simp_tac (srw_ss()) [] >> ‘(OLEAST n. s2.MEM (s2.R 5w + n2w n) = 0w) = SOME zoff’ - by (glAbbrs 2 >> DEEP_INTRO_TAC whileTheory.OLEAST_INTRO >> simp[] >> + by (glAbbrs 2 >> DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO >> simp[] >> conj_tac >- (goal_assum drule) >> rw[] >> ‘¬(zoff < n) ∧ ¬(n < zoff)’ suffices_by simp[] >> metis_tac[]) >> qpat_x_assum ‘Abbrev (s3 = _)’ mp_tac >> @@ -3436,7 +3436,7 @@ Proof ,ag32Theory.dfn'Normal_def, ag32Theory.norm_def ,ag32Theory.ALU_def, ag32Theory.ri2word_def, ag32Theory.incPC_def] \\ simp[ag32_ffi_get_arg_find1_thm] - \\ simp[whileTheory.OLEAST_def] + \\ simp[WhileTheory.OLEAST_def] \\ IF_CASES_TAC \\ fs[] \\ simp[APPLY_UPDATE_THM] \\ simp[word_add_n2w] @@ -3539,7 +3539,7 @@ Proof (SIMP_RULE bool_ss [PULL_EXISTS] ag32_ffi_get_arg_find_decomp1_thm)>> simp[] >> ‘(OLEAST n. s1.MEM (s1.R 5w + n2w n) = 0w) = SOME off’ - by (DEEP_INTRO_TAC whileTheory.OLEAST_INTRO >> simp[Abbr`s1`] >> + by (DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO >> simp[Abbr`s1`] >> conj_tac >- goal_assum drule >> qx_gen_tac `n` >> strip_tac >> ‘¬(n < off) ∧ ¬(off < n)’ suffices_by simp[] >> metis_tac[]) >> simp[ag32_ffi_get_arg_find1_thm, combinTheory.UPDATE_def] >> @@ -3568,7 +3568,7 @@ Proof ,ag32Theory.dfn'Normal_def, ag32Theory.norm_def ,ag32Theory.ALU_def, ag32Theory.ri2word_def, ag32Theory.incPC_def] \\ simp[ag32_ffi_get_arg_find1_thm] - \\ simp[whileTheory.OLEAST_def] + \\ simp[WhileTheory.OLEAST_def] \\ IF_CASES_TAC \\ fs[] \\ simp[APPLY_UPDATE_THM] \\ simp[word_add_n2w] diff --git a/compiler/backend/proofs/bvl_to_bviProofScript.sml b/compiler/backend/proofs/bvl_to_bviProofScript.sml index 2a164916cd..4067ba29d5 100644 --- a/compiler/backend/proofs/bvl_to_bviProofScript.sml +++ b/compiler/backend/proofs/bvl_to_bviProofScript.sml @@ -741,7 +741,7 @@ Proof \\ ‘p ≠ new_p ∧ new_p ∉ FDOM s.refs’ by (`∃x. (λptr. ptr NOTIN FDOM (s.refs |+ (p,ARB))) x` by (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM]) - \\ drule whileTheory.LEAST_INTRO \\ fs []) + \\ drule WhileTheory.LEAST_INTRO \\ fs []) \\ fs [] \\ simp [Abbr‘s1’,FLOOKUP_UPDATE,Abbr‘new_refs’,inc_clock_def] \\ disch_then $ qspecl_then [‘T’,‘T’,‘LENGTH ls’] mp_tac @@ -1548,6 +1548,7 @@ Theorem eval_ind_alt: P (xs,env,s) ⇒ P ([Let xs x2],env,s)) ∧ (∀x1 env s. P ([x1],env,s) ⇒ P ([Raise x1],env,s)) ∧ + (∀op xs env s. P (xs,env,s) ⇒ P ([Op op xs],env,s)) ∧ (∀x1 x2 env s1. (∀v3 s v8 v. evaluate ([x1],env,s1) = (v3,s) ∧ v3 = Rerr v8 ∧ @@ -1555,7 +1556,6 @@ Theorem eval_ind_alt: P ([x2],v::env,s)) ∧ (∀xs env. list_size exp_size xs <= exp_size x1 ⇒ P (xs,env,s1)) ⇒ P ([Handle x1 x2],env,s1)) ∧ - (∀op xs env s. P (xs,env,s) ⇒ P ([Op op xs],env,s)) ∧ (∀x env s. (s.clock ≠ 0 ⇒ P ([x],env,dec_clock 1 s)) ⇒ P ([Tick x],env,s)) ∧ @@ -2241,12 +2241,12 @@ Proof \\ `~(x IN FDOM s5.refs)` by (`?p. (\ptr. ptr NOTIN FDOM s5.refs) p` by (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM]) - \\ IMP_RES_TAC whileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[] + \\ IMP_RES_TAC WhileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[] \\ REV_FULL_SIMP_TAC std_ss []) \\ `~(y IN FDOM t2.refs)` by (`?p. (\ptr. ptr NOTIN FDOM t2.refs) p` by (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM]) - \\ IMP_RES_TAC whileTheory.LEAST_INTRO + \\ IMP_RES_TAC WhileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[bvi_to_bvl_def] \\ REV_FULL_SIMP_TAC (srw_ss()) [bvi_to_bvl_def]) \\ full_simp_tac(srw_ss())[] @@ -2345,12 +2345,12 @@ Proof \\ `~(x IN FDOM s5.refs)` by (`?p. (\ptr. ptr NOTIN FDOM s5.refs) p` by (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM]) - \\ IMP_RES_TAC whileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[] + \\ IMP_RES_TAC WhileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[] \\ REV_FULL_SIMP_TAC std_ss []) \\ `~(y IN FDOM t2.refs)` by (`?p. (\ptr. ptr NOTIN FDOM t2.refs) p` by (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM]) - \\ IMP_RES_TAC whileTheory.LEAST_INTRO + \\ IMP_RES_TAC WhileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[bvi_to_bvl_def] \\ REV_FULL_SIMP_TAC (srw_ss()) [bvi_to_bvl_def]) \\ full_simp_tac(srw_ss())[] @@ -2439,12 +2439,12 @@ Proof \\ `~(x IN FDOM s5.refs)` by (`?p. (\ptr. ptr NOTIN FDOM s5.refs) p` by (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM]) - \\ IMP_RES_TAC whileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[] + \\ IMP_RES_TAC WhileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[] \\ REV_FULL_SIMP_TAC std_ss []) \\ `~(y IN FDOM t2.refs)` by (`?p. (\ptr. ptr NOTIN FDOM t2.refs) p` by (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM]) - \\ IMP_RES_TAC whileTheory.LEAST_INTRO + \\ IMP_RES_TAC WhileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[bvi_to_bvl_def] \\ REV_FULL_SIMP_TAC (srw_ss()) [bvi_to_bvl_def]) \\ full_simp_tac(srw_ss())[] diff --git a/compiler/backend/proofs/clos_to_bvlProofScript.sml b/compiler/backend/proofs/clos_to_bvlProofScript.sml index 04ccb496b9..234d1f8161 100644 --- a/compiler/backend/proofs/clos_to_bvlProofScript.sml +++ b/compiler/backend/proofs/clos_to_bvlProofScript.sml @@ -4722,7 +4722,7 @@ Proof \\ full_simp_tac(srw_ss())[DRESTRICT_DEF,FAPPLY_FUPDATE_THM] \\ REPEAT STRIP_TAC \\ SRW_TAC [] [] \\ ASSUME_TAC (EXISTS_NOT_IN_refs |> - SIMP_RULE std_ss [whileTheory.LEAST_EXISTS]) \\ full_simp_tac(srw_ss())[]) + SIMP_RULE std_ss [WhileTheory.LEAST_EXISTS]) \\ full_simp_tac(srw_ss())[]) \\ MATCH_MP_TAC IMP_IMP \\ reverse STRIP_TAC >- (REPEAT STRIP_TAC \\ qexists_tac`ck'` @@ -4738,7 +4738,7 @@ Proof \\ full_simp_tac(srw_ss())[DRESTRICT_DEF,FAPPLY_FUPDATE_THM] \\ REPEAT STRIP_TAC \\ SRW_TAC [] [] \\ ASSUME_TAC (EXISTS_NOT_IN_refs |> - SIMP_RULE std_ss [whileTheory.LEAST_EXISTS]) + SIMP_RULE std_ss [WhileTheory.LEAST_EXISTS]) \\ full_simp_tac(srw_ss())[]) \\ conj_tac >- simp [] \\ reverse (REPEAT STRIP_TAC) THEN1 diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml index 95cddf542a..67a13b9a19 100644 --- a/compiler/backend/proofs/data_to_wordProofScript.sml +++ b/compiler/backend/proofs/data_to_wordProofScript.sml @@ -7,7 +7,7 @@ Ancestors data_to_word_gcProof word_to_wordProof wordProps data_to_word wordLang wordSem[qualified] dataProps copying_gc int_bitwise finite_map data_to_word_memoryProof data_to_word_bignumProof - data_to_word_assignProof wordConvs wordConvsProof while set_sep + data_to_word_assignProof wordConvs wordConvsProof While set_sep semanticsProps alignment word_bignum word_bignumProof gen_gc_partial gc_shared gen_gc[qualified] Libs diff --git a/compiler/backend/proofs/data_to_word_assignProofScript.sml b/compiler/backend/proofs/data_to_word_assignProofScript.sml index 48c3ea5f1e..5096ea029e 100644 --- a/compiler/backend/proofs/data_to_word_assignProofScript.sml +++ b/compiler/backend/proofs/data_to_word_assignProofScript.sml @@ -7,7 +7,7 @@ Libs Ancestors data_to_word_memoryProof data_to_word_gcProof dataSem wordSem[qualified] data_to_word int_bitwise dataProps - copying_gc data_to_word_bignumProof wordProps while set_sep + copying_gc data_to_word_bignumProof wordProps While set_sep semanticsProps alignment backendProps word_bignum wordLang word_bignumProof gen_gc_partial gc_shared word_gcFunctions gen_gc[qualified] bvi_to_data[qualified] diff --git a/compiler/backend/proofs/data_to_word_gcProofScript.sml b/compiler/backend/proofs/data_to_word_gcProofScript.sml index d6590d1ca7..91ba6a4041 100644 --- a/compiler/backend/proofs/data_to_word_gcProofScript.sml +++ b/compiler/backend/proofs/data_to_word_gcProofScript.sml @@ -7,7 +7,7 @@ Libs Ancestors mllist dataSem wordSem[qualified] data_to_word backendProps data_to_word_memoryProof dataProps copying_gc int_bitwise - finite_map wordProps while set_sep semanticsProps alignment + finite_map wordProps While set_sep semanticsProps alignment word_bignum wordLang word_bignumProof gen_gc_partial gc_shared word_gcFunctions gen_gc[qualified] diff --git a/compiler/backend/proofs/data_to_word_memoryProofScript.sml b/compiler/backend/proofs/data_to_word_memoryProofScript.sml index 25d9ff223f..0f83116cc3 100644 --- a/compiler/backend/proofs/data_to_word_memoryProofScript.sml +++ b/compiler/backend/proofs/data_to_word_memoryProofScript.sml @@ -4,7 +4,7 @@ Theory data_to_word_memoryProof Ancestors dataSem dataProps wordSem data_to_word gc_shared gc_combined - word_gcFunctions copying_gc int_bitwise set_sep labSem while + word_gcFunctions copying_gc int_bitwise set_sep labSem While alignment multiword Libs preamble helperLib blastLib[qualified] diff --git a/compiler/backend/proofs/flat_to_closProofScript.sml b/compiler/backend/proofs/flat_to_closProofScript.sml index a1d2057688..c1c73d8f7e 100644 --- a/compiler/backend/proofs/flat_to_closProofScript.sml +++ b/compiler/backend/proofs/flat_to_closProofScript.sml @@ -550,7 +550,7 @@ Theorem state_rel_LEAST: Proof fs [state_rel_def,store_rel_def] \\ rw [] \\ ho_match_mp_tac - (whileTheory.LEAST_ELIM + (WhileTheory.LEAST_ELIM |> ISPEC ``\x. x = LENGTH s1.refs`` |> CONV_RULE (DEPTH_CONV BETA_CONV)) \\ fs [] \\ rpt strip_tac \\ fs [FLOOKUP_DEF] diff --git a/compiler/backend/proofs/lab_to_targetProofScript.sml b/compiler/backend/proofs/lab_to_targetProofScript.sml index f50225ac52..4c62fb6763 100644 --- a/compiler/backend/proofs/lab_to_targetProofScript.sml +++ b/compiler/backend/proofs/lab_to_targetProofScript.sml @@ -10349,7 +10349,7 @@ val semantics_compile_lemma = Q.prove( rw[]>> gvs[find_index_LEAST_EL] >> qpat_x_assum `(LEAST n'. _) = n` mp_tac >> - DEEP_INTRO_TAC whileTheory.LEAST_ELIM >> + DEEP_INTRO_TAC WhileTheory.LEAST_ELIM >> conj_tac >- (fs[MEM_EL] >> metis_tac[]) >> simp[] >> diff --git a/compiler/backend/proofs/source_evalProofScript.sml b/compiler/backend/proofs/source_evalProofScript.sml index 514921126e..eb8f77e906 100644 --- a/compiler/backend/proofs/source_evalProofScript.sml +++ b/compiler/backend/proofs/source_evalProofScript.sml @@ -1783,7 +1783,7 @@ Proof \\ rw [] \\ first_x_assum (qspec_then `j` mp_tac) \\ simp [extract_oracle_def] - \\ DEEP_INTRO_TAC whileTheory.OLEAST_INTRO + \\ DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO \\ rpt strip_tac >- ( first_x_assum (qspec_then `k` mp_tac) @@ -1851,8 +1851,8 @@ Triviality extract_oracle_SOME_SUC: IS_SOME (extract_oracle s env decs i) Proof simp [extract_oracle_def] - \\ DEEP_INTRO_TAC whileTheory.OLEAST_INTRO - \\ DEEP_INTRO_TAC whileTheory.OLEAST_INTRO + \\ DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO + \\ DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO \\ rw [] \\ simp [UNCURRY] \\ res_tac @@ -1867,7 +1867,7 @@ Triviality extract_oracle_0_st: FST (SND r) = ci.config_v ci.init_state Proof simp [extract_oracle_def] - \\ DEEP_INTRO_TAC whileTheory.OLEAST_INTRO + \\ DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO \\ simp [UNCURRY] \\ rw [] \\ Cases_on `evaluate_decs (s with clock := n) env decs` @@ -1910,7 +1910,7 @@ Proof SUC i < FST (FST ((orac_s t'.eval_state).oracle 0))`) >- ( rpt (POP_ASSUM (mp_tac o REWRITE_RULE [extract_oracle_def])) - \\ DEEP_INTRO_TAC whileTheory.OLEAST_INTRO + \\ DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO \\ rw [] \\ metis_tac [] ) diff --git a/compiler/backend/reg_alloc/parmoveScript.sml b/compiler/backend/reg_alloc/parmoveScript.sml index b26725dd1f..aafb2923df 100644 --- a/compiler/backend/reg_alloc/parmoveScript.sml +++ b/compiler/backend/reg_alloc/parmoveScript.sml @@ -557,9 +557,9 @@ val tac = rw[dstep_cases] >> TRY(map_every qexists_tac[`FST(LAST t')`,`SND(LAST t')`,`FRONT t'`]) >> rw[APPEND_FRONT_LAST] >> - fs[whileTheory.OLEAST_def,MEM_MAP,MEM_EL] >> + fs[WhileTheory.OLEAST_def,MEM_MAP,MEM_EL] >> metis_tac[] ) >> - fs[whileTheory.OLEAST_def] >> + fs[WhileTheory.OLEAST_def] >> BasicProvers.CASE_TAC >- ( fs[DROP_NIL] >> rw[] >> pop_assum mp_tac >> @@ -628,7 +628,7 @@ Termination fs[NULL_LENGTH,LENGTH_NIL] >> simp[LENGTH_FRONT,PRE_SUB1,LENGTH_NOT_NULL,NULL_LENGTH,LENGTH_NIL] >> NO_TAC) >> - fs[whileTheory.OLEAST_def] >> rw[] >> + fs[WhileTheory.OLEAST_def] >> rw[] >> pop_assum mp_tac >> numLib.LEAST_ELIM_TAC >> conj_tac >- metis_tac[] >> diff --git a/compiler/inference/unifyScript.sml b/compiler/inference/unifyScript.sml index cb8bad59da..5b9df80eef 100644 --- a/compiler/inference/unifyScript.sml +++ b/compiler/inference/unifyScript.sml @@ -804,7 +804,7 @@ Theorem cvwalk_tcallish: ∀x. (λn. cwfs s) x ⇒ cvwalk s x = TAILCALL (cvwalk_code s) (cvwalk s) x Proof - simp[whileTheory.TAILCALL_def, cvwalk_code_def, sum_CASE_option_CASE, + simp[WhileTheory.TAILCALL_def, cvwalk_code_def, sum_CASE_option_CASE, sum_CASE_infer_CASE, FORALL_PROD] >> simp[Once (DISCH_ALL cvwalk_thm), cwfs_def] QED @@ -812,7 +812,7 @@ QED Theorem cvwalk_cleaned: ∀x. (λn. cwfs s) x ⇒ cvwalk s x = TAILREC (cvwalk_code s) x Proof - match_mp_tac whileTheory.TAILREC_GUARD_ELIMINATION >> + match_mp_tac WhileTheory.TAILREC_GUARD_ELIMINATION >> rpt conj_tac >- ACCEPT_TAC cvwalk_preserves_precond >- (rpt strip_tac >> qexists_tac ‘cvwalkR s’ >> conj_tac @@ -831,7 +831,7 @@ Proof simp[FUN_EQ_THM] QED Theorem tcvwalk_thm = - tcvwalk_def |> SRULE[Once whileTheory.TAILREC, cvwalk_code_def] + tcvwalk_def |> SRULE[Once WhileTheory.TAILREC, cvwalk_code_def] |> SRULE[sum_CASE_option_CASE, sum_CASE_infer_CASE] |> SRULE[GSYM tcvwalk_def, cvwalk_eta, GSYM (SRULE [FUN_EQ_THM] cvwalk_code_def)] @@ -1180,7 +1180,7 @@ Theorem kcocwl_tcallish: ∀x. (λv. cwfs s) x ⇒ kcocwl s n x = TAILCALL (kcocwl_code s n) (kcocwl s n) x Proof - simp[FORALL_PROD, whileTheory.TAILCALL_def, kcocwl_code_def, + simp[FORALL_PROD, WhileTheory.TAILCALL_def, kcocwl_code_def, sum_CASE_list_CASE, sum_CASE_infer_CASE, sum_CASE_COND] >> rpt strip_tac >> rename [‘kcocwl s n wl ⇔ _’] >> Cases_on ‘wl’ >> simp[Once kcocwl_thm, SimpLHS] >> @@ -1190,7 +1190,7 @@ QED Theorem kcocwl_cleaned: ∀x. (λv. cwfs s) x ⇒ kcocwl s n x = TAILREC (kcocwl_code s n) x Proof - match_mp_tac whileTheory.TAILREC_GUARD_ELIMINATION >> rpt conj_tac + match_mp_tac WhileTheory.TAILREC_GUARD_ELIMINATION >> rpt conj_tac >- ACCEPT_TAC kcocwl_preserves_precond >- (qx_gen_tac ‘wl’ >> strip_tac >> qexists ‘kcocwlR s n’ >> conj_tac @@ -1216,7 +1216,7 @@ Theorem disj2cond[local] = DECIDE “p ∨ q ⇔ if p then T else q” Theorem tcocwl_thm = tcocwl_def - |> SRULE[Once whileTheory.TAILREC, sum_CASE_list_CASE, + |> SRULE[Once WhileTheory.TAILREC, sum_CASE_list_CASE, sum_CASE_infer_CASE, sum_CASE_COND, kcocwl_code_def] |> SRULE [GSYM tcocwl_def, GSYM kcocwl_code_def] |> PURE_REWRITE_RULE [disj2cond] @@ -1457,7 +1457,7 @@ Theorem kcwalkstarwl_tcallish: (λ(v,its,k). kcwalkstarwl s v its k) x = TAILCALL (kcwalkstarwl_code s) (λ(v,its,k). kcwalkstarwl s v its k) x Proof - simp[whileTheory.TAILCALL_def, kcwalkstarwl_code_def, FORALL_PROD, + simp[WhileTheory.TAILCALL_def, kcwalkstarwl_code_def, FORALL_PROD, sum_CASE_COND, sum_CASE_list_CASE, sum_CASE_infer_CASE, sum_CASE_wstarcont_CASE] >> simp[Once $ DISCH_ALL kcwalkstarwl_thm] @@ -1467,7 +1467,7 @@ Theorem kcwalkstarwl_cleaned: ∀x. (λ(v,its,k). cwfs s) x ⇒ (λ(v,its,k). kcwalkstarwl s v its k) x = TAILREC (kcwalkstarwl_code s) x Proof - match_mp_tac whileTheory.TAILREC_GUARD_ELIMINATION >> rpt conj_tac + match_mp_tac WhileTheory.TAILREC_GUARD_ELIMINATION >> rpt conj_tac >- ACCEPT_TAC kcwalkstarwl_preserves_precond >- (qx_gen_tac ‘trip’ >> strip_tac >> qexists ‘kcwalkstarwlR s’ >> conj_tac @@ -1491,7 +1491,7 @@ End Theorem tcwalkstarwl_thm = tcwalkstarwl_def - |> SRULE[Once whileTheory.TAILREC] + |> SRULE[Once WhileTheory.TAILREC] |> SRULE[kcwalkstarwl_code_def, sum_CASE_COND, sum_CASE_wstarcont_CASE, sum_CASE_list_CASE, sum_CASE_infer_CASE] @@ -1600,7 +1600,7 @@ Theorem kcunifywl_tcallish: (λ(s,k). kcunifywl s k) x = TAILCALL cunify_code (λ(s,k). kcunifywl s k) x Proof - simp[whileTheory.TAILCALL_def, FORALL_PROD, sum_CASE_list_CASE, + simp[WhileTheory.TAILCALL_def, FORALL_PROD, sum_CASE_list_CASE, cunify_code_def, sum_CASE_pair_CASE, sum_CASE_infer_CASE, sum_CASE_COND] >> qx_genl_tac [‘s’, ‘k’] >> strip_tac >> @@ -1992,7 +1992,7 @@ Theorem kcunifywl_cleaned: ∀x. (λ(s,wl). cwfs s) x ⇒ (λ(s,wl). kcunifywl s wl) x = TAILREC cunify_code x Proof - match_mp_tac whileTheory.TAILREC_GUARD_ELIMINATION >> rpt conj_tac + match_mp_tac WhileTheory.TAILREC_GUARD_ELIMINATION >> rpt conj_tac >- ACCEPT_TAC kcunifywl_preserves_precond >- (rpt strip_tac >> qexists ‘kcunifywlR’ >> conj_tac >- (irule $ iffLR WF_EQ_WFP >> simp[WF_kcunifywlR]) >> @@ -2005,7 +2005,7 @@ Definition tcunify_def: End Theorem tcunify_thm = - tcunify_def |> SRULE[Once whileTheory.TAILREC] + tcunify_def |> SRULE[Once WhileTheory.TAILREC] |> SRULE[cunify_code_def, sum_CASE_list_CASE, sum_CASE_pair_CASE, sum_CASE_infer_CASE, sum_CASE_COND] diff --git a/examples/filterProgScript.sml b/examples/filterProgScript.sml index 4b9b7dab74..331256848e 100644 --- a/examples/filterProgScript.sml +++ b/examples/filterProgScript.sml @@ -998,7 +998,7 @@ Proof impl_tac >- rw[every_LNTH,LNTH_LGENLIST,next_filter_events,LFINITE_fromList] >> simp[SimpL ``$==>``,exists_LNTH,LNTH_LGENLIST] >> Ho_Rewrite.PURE_ONCE_REWRITE_TAC [cut_at_null_simplify] >> - disch_then(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[whileTheory.LEAST_EXISTS]) >> + disch_then(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[WhileTheory.LEAST_EXISTS]) >> rename1 `LNTH n0` >> qmatch_goalsub_abbrev_tac `LGENLIST f` >> Q.ISPECL_THEN [`n0`,`f`] assume_tac (GEN_ALL LGENLIST_CHUNK_GENLIST) >> @@ -1047,7 +1047,7 @@ Proof impl_tac >- rw[every_LNTH,LNTH_LGENLIST,next_filter_events,LFINITE_fromList] >> simp[SimpL ``$==>``,exists_LNTH,LNTH_LGENLIST] >> Ho_Rewrite.PURE_ONCE_REWRITE_TAC [cut_at_null_simplify] >> - disch_then(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[whileTheory.LEAST_EXISTS]) >> + disch_then(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[WhileTheory.LEAST_EXISTS]) >> rename1 `LNTH n0` >> qmatch_goalsub_abbrev_tac `LGENLIST f` >> Q.ISPECL_THEN [`n0`,`f`] assume_tac (GEN_ALL LGENLIST_CHUNK_GENLIST) >> diff --git a/misc/miscScript.sml b/misc/miscScript.sml index 57988b3c7d..e977841ced 100644 --- a/misc/miscScript.sml +++ b/misc/miscScript.sml @@ -2316,8 +2316,8 @@ QED Theorem OLEAST_SOME_IMP: $OLEAST P = SOME i ⇒ P i ∧ (∀n. n < i ⇒ ¬P n) Proof - simp[whileTheory.OLEAST_def] - \\ metis_tac[whileTheory.LEAST_EXISTS_IMP] + simp[WhileTheory.OLEAST_def] + \\ metis_tac[WhileTheory.LEAST_EXISTS_IMP] QED Theorem EXP2_EVEN: diff --git a/pancake/semantics/panItreeSemScript.sml b/pancake/semantics/panItreeSemScript.sml index ce4ce941b4..3454f575ca 100644 --- a/pancake/semantics/panItreeSemScript.sml +++ b/pancake/semantics/panItreeSemScript.sml @@ -714,7 +714,7 @@ Theorem ltree_lift_state_simps: ltree_lift_state f st' ((g ∘ (SND ek)) a) Proof rpt conj_tac >> - rw[ltree_lift_state_def, Once whileTheory.WHILE] >> + rw[ltree_lift_state_def, Once WhileTheory.WHILE] >> rw[ELIM_UNCURRY] >> PURE_TOP_CASE_TAC >> rw[] QED diff --git a/translator/std_preludeScript.sml b/translator/std_preludeScript.sml index 6ca46ff8de..2a46eeee37 100644 --- a/translator/std_preludeScript.sml +++ b/translator/std_preludeScript.sml @@ -4,7 +4,7 @@ *) Theory std_prelude Ancestors - ast semanticPrimitives while evaluate ml_translator + ast semanticPrimitives While evaluate ml_translator Libs preamble ml_translatorLib ml_progLib From 365016e6ac14b152ccd00d81a5fe286de2ed9005 Mon Sep 17 00:00:00 2001 From: tanyongkiam Date: Tue, 30 Sep 2025 23:55:18 +0800 Subject: [PATCH 106/112] fix paths --- misc/Holmakefile | 2 +- semantics/Holmakefile | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/misc/Holmakefile b/misc/Holmakefile index f01a823001..df0cd89120 100644 --- a/misc/Holmakefile +++ b/misc/Holmakefile @@ -1,4 +1,4 @@ -INCLUDES = $(CAKEMLDIR)/developers $(HOLDIR)/examples/machine-code/hoare-triple $(HOLDIR)/examples/fun-op-sem/lprefix_lub \ +INCLUDES = $(CAKEMLDIR)/developers $(HOLDIR)/examples/machine-code/hoare-triple $(HOLDIR)/examples/pl-semantics/lprefix_lub \ $(HOLDIR)/examples/formal-languages/context-free all: $(DEFAULT_TARGETS) README.md diff --git a/semantics/Holmakefile b/semantics/Holmakefile index 72475f54c9..26d96b954e 100644 --- a/semantics/Holmakefile +++ b/semantics/Holmakefile @@ -1,5 +1,5 @@ INCLUDES = $(HOLDIR)/examples/formal-languages/context-free\ - $(HOLDIR)/examples/fun-op-sem/lprefix_lub\ + $(HOLDIR)/examples/pl-semantics/lprefix_lub\ $(CAKEMLDIR)/developers $(CAKEMLDIR)/misc\ ffi From b9917a888de5f4de9ad77a68be19934c2d98f5fc Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Tue, 30 Sep 2025 18:05:56 +0200 Subject: [PATCH 107/112] Progress on Thunk proofs in compiler --- .../proofs/data_to_word_gcProofScript.sml | 81 ++++++++++++------- 1 file changed, 54 insertions(+), 27 deletions(-) diff --git a/compiler/backend/proofs/data_to_word_gcProofScript.sml b/compiler/backend/proofs/data_to_word_gcProofScript.sml index 5120cc7267..cbf8103508 100644 --- a/compiler/backend/proofs/data_to_word_gcProofScript.sml +++ b/compiler/backend/proofs/data_to_word_gcProofScript.sml @@ -5357,29 +5357,17 @@ QED val _ = temp_delsimps ["fromAList_def"] -Theorem state_rel_call_env_push: - state_rel c l1 l2 s t (ZIP(xs,ws)) locs ∧ - LENGTH xs = LENGTH ws ∧ - cut_env r s.locals = SOME x ∧ - cut_envs (adjust_sets r) t.locals = SOME y ⇒ - state_rel c q l - (call_env xs ss (push_env x F (dec_clock s))) - (call_env (Loc q l::ws) ss (push_env y NONE (dec_clock t))) [] - ((l1,l2)::locs) -Proof - cheat (* state_rel_call_env_push_env *) -QED - -Theorem state_rel_call_env_push_env: (* TODO: tidy up proof *) - !opt:(num # 'a wordLang$prog # num # num) option. - state_rel c l1 l2 s (t:('a,'c,'ffi)wordSem$state) [] locs /\ - get_vars args s.locals = SOME xs /\ - get_vars (MAP adjust_var args) t = SOME ws /\ - dataSem$cut_env r s.locals = SOME x /\ - wordSem$cut_envs (adjust_sets r) t.locals = SOME y ==> - state_rel c q l (call_env xs ss (push_env x (IS_SOME opt) (dec_clock s))) - (call_env (Loc q l::ws) ss (push_env y opt (dec_clock t))) [] - ((l1,l2)::locs) +Theorem state_rel_call_env_push_opt: + ∀(opt:(num # 'a wordLang$prog # num # num) option). + state_rel c l1 l2 s t (ZIP(xs,ws)) locs ∧ + lookup 0 t.locals = SOME (Loc l1 l2) ∧ + LENGTH xs = LENGTH ws ∧ + cut_env r s.locals = SOME x ∧ + cut_envs (adjust_sets r) t.locals = SOME y ⇒ + state_rel c q l + (call_env xs ss (push_env x (IS_SOME opt) (dec_clock s))) + (call_env (Loc q l::ws) ss (push_env y opt (dec_clock t))) [] + ((l1,l2)::locs) Proof Cases \\ TRY (PairCases_on `x'`) \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[state_rel_def,call_env_def,push_env_def, @@ -5432,16 +5420,16 @@ Proof \\ full_simp_tac(srw_ss())[DIV_LT_X] \\ `k < 2 + LENGTH xs * 2 /\ 0 < LENGTH xs * 2` by (rev_full_simp_tac(srw_ss())[] \\ Cases_on `xs` \\ full_simp_tac(srw_ss())[] - THEN1 (Cases_on `k` \\ full_simp_tac(srw_ss())[] - \\ Cases_on `n` \\ full_simp_tac(srw_ss())[] \\ decide_tac) - \\ full_simp_tac(srw_ss())[MULT_CLAUSES] \\ decide_tac) + THEN1 (gvs [] \\ Cases_on `k` \\ gvs [DECIDE “SUC n < 2 ⇔ n = 0”]) + \\ Cases_on ‘ws’ \\ gvs []) \\ full_simp_tac(srw_ss())[] \\ qexists_tac `(k - 2) DIV 2` \\ full_simp_tac(srw_ss())[] \\ full_simp_tac(srw_ss())[DIV_LT_X] + \\ gvs [] \\ Cases_on `k` \\ full_simp_tac(srw_ss())[] \\ Cases_on `n` \\ full_simp_tac(srw_ss())[DECIDE ``SUC (SUC n) = n + 2``] \\ full_simp_tac(srw_ss())[MATCH_MP ADD_DIV_RWT (DECIDE ``0<2:num``)] \\ full_simp_tac(srw_ss())[GSYM ADD1,EL] \\ NO_TAC) - \\ full_simp_tac(srw_ss())[] \\ disj1_tac \\ disj2_tac + \\ full_simp_tac(srw_ss())[] \\ disj2_tac \\ disj1_tac \\ Cases_on `x'` \\ full_simp_tac(srw_ss())[join_env_def,MEM_MAP,MEM_FILTER,EXISTS_PROD] \\ full_simp_tac(srw_ss())[MEM_toAList] \\ srw_tac[][MEM_ZIP] \\ full_simp_tac(srw_ss())[lookup_fromList2,lookup_fromList,lookup_inter_alt] @@ -5465,6 +5453,45 @@ Proof \\ imp_res_tac lookup_adjust_var_after_cut \\ gvs [] QED +Theorem state_rel_call_env_push: + state_rel c l1 l2 s t (ZIP(xs,ws)) locs ∧ + LENGTH xs = LENGTH ws ∧ + lookup 0 t.locals = SOME (Loc l1 l2) ∧ + cut_env r s.locals = SOME x ∧ + cut_envs (adjust_sets r) t.locals = SOME y ⇒ + state_rel c q l + (call_env xs ss (push_env x F (dec_clock s))) + (call_env (Loc q l::ws) ss (push_env y NONE (dec_clock t))) [] + ((l1,l2)::locs) +Proof + strip_tac + \\ drule_all (state_rel_call_env_push_opt |> Q.SPEC ‘NONE’ |> SRULE []) + \\ fs [] +QED + +Theorem state_rel_call_env_push_env: (* TODO: tidy up proof *) + !opt:(num # 'a wordLang$prog # num # num) option. + state_rel c l1 l2 s (t:('a,'c,'ffi)wordSem$state) [] locs /\ + get_vars args s.locals = SOME xs /\ + get_vars (MAP adjust_var args) t = SOME ws /\ + dataSem$cut_env r s.locals = SOME x /\ + wordSem$cut_envs (adjust_sets r) t.locals = SOME y ==> + state_rel c q l (call_env xs ss (push_env x (IS_SOME opt) (dec_clock s))) + (call_env (Loc q l::ws) ss (push_env y opt (dec_clock t))) [] + ((l1,l2)::locs) +Proof + rpt strip_tac + \\ irule state_rel_call_env_push_opt + \\ imp_res_tac get_vars_IMP_LENGTH \\ full_simp_tac(srw_ss())[] + \\ imp_res_tac wordPropsTheory.get_vars_length_lemma \\ full_simp_tac(srw_ss())[IS_SOME_IF] + \\ rpt $ first_x_assum $ irule_at $ Pos hd + \\ fs [state_rel_def] + \\ rpt $ first_x_assum $ irule_at Any + \\ full_simp_tac std_ss [GSYM APPEND_ASSOC] + \\ drule_all word_ml_inv_get_vars_IMP + \\ fs [] +QED + Theorem find_code_thm_ret: state_rel c l1 l2 s (t:('a,'c,'ffi)wordSem$state) [] locs /\ get_vars args s.locals = SOME xs /\ From 5305161e85dca0ab290142528d2eaebd91eac97a Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Tue, 30 Sep 2025 23:36:49 +0200 Subject: [PATCH 108/112] Fix sexp_parserProg --- .../bootstrap/translation/sexp_parserProgScript.sml | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/compiler/bootstrap/translation/sexp_parserProgScript.sml b/compiler/bootstrap/translation/sexp_parserProgScript.sml index 1865b07e54..e89acab695 100644 --- a/compiler/bootstrap/translation/sexp_parserProgScript.sml +++ b/compiler/bootstrap/translation/sexp_parserProgScript.sml @@ -278,15 +278,8 @@ val sexplit_side = Q.prove( val r = translate sexppat_alt_def; -val sexppat_alt_side = Q.prove( - `(∀x. sexppat_alt_side x = T) ∧ - (∀x. sexppat_list_side x = T)`, - ho_match_mp_tac sexppat_alt_ind \\ rw[] \\ - rw[Once(theorem"sexppat_alt_side_def")]) - |> update_precondition; - -val r = translate decode_bool_def; -val r = translate encode_bool_def; +val r = translate encode_thunk_mode_def; +val r = translate decode_thunk_mode_def; val r = translate (fromSexpTheory.sexpop_def |> REWRITE_RULE [decode_control_eq]); From 5e79b20f46bca3250e35759aaf52f446d5889b43 Mon Sep 17 00:00:00 2001 From: Magnus Myreen Date: Wed, 1 Oct 2025 00:56:48 +0200 Subject: [PATCH 109/112] Fixes for force_thunk --- compiler/bootstrap/translation/to_word32ProgScript.sml | 3 +++ compiler/bootstrap/translation/to_word64ProgScript.sml | 3 +++ 2 files changed, 6 insertions(+) diff --git a/compiler/bootstrap/translation/to_word32ProgScript.sml b/compiler/bootstrap/translation/to_word32ProgScript.sml index aec9496345..8cbca4f2c7 100644 --- a/compiler/bootstrap/translation/to_word32ProgScript.sml +++ b/compiler/bootstrap/translation/to_word32ProgScript.sml @@ -310,6 +310,9 @@ val data_to_word_assign_side = Q.prove(` metis_tac[word_op_type_nchotomy,option_nchotomy,NOT_NONE_SOME,list_distinct]) |> update_precondition *) +val _ = translate (data_to_wordTheory.force_thunk_def + |> SRULE [bytes_in_word_def] |> conv32 |> wcomp_simp); + Theorem comp_ind = data_to_wordTheory.comp_ind|> conv32|> wcomp_simp (* Inlines the let k = 8 manually *) diff --git a/compiler/bootstrap/translation/to_word64ProgScript.sml b/compiler/bootstrap/translation/to_word64ProgScript.sml index f1930ef39f..1539126a7f 100644 --- a/compiler/bootstrap/translation/to_word64ProgScript.sml +++ b/compiler/bootstrap/translation/to_word64ProgScript.sml @@ -300,6 +300,9 @@ val data_to_word_assign_side = Q.prove(` metis_tac[word_op_type_nchotomy,option_nchotomy,NOT_NONE_SOME,list_distinct]) |> update_precondition *) +val _ = translate (data_to_wordTheory.force_thunk_def + |> SRULE [bytes_in_word_def] |> conv64 |> wcomp_simp); + Theorem comp_ind = data_to_wordTheory.comp_ind|> conv64|> wcomp_simp (* Inlines the let k = 8 manually *) From 8659f8e31d1d502e8f3440eae1b6cf174a9cb97c Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Wed, 1 Oct 2025 04:46:25 +0300 Subject: [PATCH 110/112] Fix `compiler/repl` --- compiler/repl/evaluate_initScript.sml | 36 ++++--- compiler/repl/evaluate_skipScript.sml | 136 ++++++++++++++------------ 2 files changed, 100 insertions(+), 72 deletions(-) diff --git a/compiler/repl/evaluate_initScript.sml b/compiler/repl/evaluate_initScript.sml index 99d2bdc770..1a32857a8d 100644 --- a/compiler/repl/evaluate_initScript.sml +++ b/compiler/repl/evaluate_initScript.sml @@ -690,16 +690,31 @@ Theorem do_app_ok[allow_rebind] = SIMP_RULE (srw_ss()) [LET_THM] do_app_ok; Theorem dest_thunk_ok: state_ok s ∧ - dest_thunk vs s.refs = IsThunk m v ⇒ - state_ok (dec_clock s) ∧ env_ok (dec_clock s) (sing_env n v) + dest_thunk vs s.refs = IsThunk m v ∧ + do_opapp [v; Conv NONE []] = SOME (env,e) ⇒ + state_ok (dec_clock s) ∧ env_ok (dec_clock s) env Proof rw [] >- gvs [dec_clock_def, state_ok_def, state_rel_def] - \\ gvs [dec_clock_def, sing_env_def, env_ok_def, env_rel_def, ctor_rel_def] - \\ irule nsAll2_nsBind \\ rw [] \\ gvs [] + \\ gvs [do_opapp_def, AllCaseEqs()] + >- ( + gvs [dec_clock_def, env_ok_def, env_rel_def] + \\ irule_at Any nsAll2_nsBind \\ gvs [] + \\ conj_tac >- simp [v_rel_def] + \\ gvs [state_ok_def, state_rel_def, FLOOKUP_FUN_FMAP] + \\ gvs [oneline dest_thunk_def, AllCaseEqs(), store_lookup_def] + \\ first_x_assum drule \\ rw [ref_rel_def, v_rel_def, env_rel_def]) + \\ simp [env_ok_def, env_rel_def, dec_clock_def] + \\ irule_at Any nsAll2_nsBind \\ gvs [] + \\ conj_tac >- simp [v_rel_def] + \\ simp [semanticPrimitivesPropsTheory.build_rec_env_merge] + \\ irule_at Any nsAll2_nsAppend \\ gvs [] + \\ irule_at Any nsAll2_alist_to_ns \\ gvs [] + \\ gs [EVERY2_MAP, LAMBDA_PROD, v_rel_def, env_rel_def] + \\ rw [ELIM_UNCURRY, LIST_REL_EL_EQN] \\ gvs [state_ok_def, state_rel_def, FLOOKUP_FUN_FMAP] \\ gvs [oneline dest_thunk_def, AllCaseEqs(), store_lookup_def] - \\ first_x_assum drule \\ rw [ref_rel_def] + \\ first_x_assum drule \\ rw [ref_rel_def, v_rel_def, env_rel_def] QED Theorem evaluate_ok_Op: @@ -718,7 +733,7 @@ Proof Cases_on ‘op’ \\ full_simp_tac (srw_ss()) [] \\ Cases_on ‘t'’ \\ full_simp_tac (srw_ss()) [AllCaseEqs()] \\ gvs [] >- ( - drule_all_then (qspec_then ‘"f"’ assume_tac) dest_thunk_ok \\ gvs [] + drule_all dest_thunk_ok \\ rw [] \\ gvs [] \\ qpat_x_assum ‘state_ok st2’ mp_tac \\ rw [state_ok_def, state_rel_def] \\ gvs [FLOOKUP_FUN_FMAP] >- simp [INJ_DEF, FUN_FMAP_DEF] @@ -726,13 +741,12 @@ Proof \\ gvs [oneline update_thunk_def, AllCaseEqs(), store_assign_def, EL_LUPDATE] \\ IF_CASES_TAC \\ gvs [ref_rel_def, v_ok_def]) - >- ( - drule_all_then (qspec_then ‘"f"’ assume_tac) dest_thunk_ok \\ gvs [])) + >- (drule_all dest_thunk_ok \\ gvs [])) >- ( Cases_on ‘op’ \\ full_simp_tac (srw_ss()) [] \\ Cases_on ‘t'’ \\ full_simp_tac (srw_ss()) [AllCaseEqs()] \\ gvs [] \\ ( - drule_all_then (qspec_then ‘"f"’ assume_tac) dest_thunk_ok \\ gvs [] + drule_all dest_thunk_ok \\ rw [] \\ gvs [] \\ imp_res_tac (CONJUNCT1 evaluate_next_type_stamp_mono) \\ imp_res_tac (CONJUNCT1 evaluate_next_exn_stamp_mono) \\ imp_res_tac (CONJUNCT1 evaluate_refs_length_mono) @@ -749,13 +763,13 @@ Proof \\ qpat_x_assum ‘state_ok st'’ mp_tac \\ rw [state_ok_def, state_rel_def] \\ gvs [FLOOKUP_FUN_FMAP] \\ first_x_assum drule \\ rw [ref_rel_def, v_ok_def]) - \\ drule_all_then (qspec_then ‘"f"’ assume_tac) dest_thunk_ok \\ gvs [] + \\ drule_all dest_thunk_ok \\ rw [] \\ gvs [] \\ gvs [EVERY_EL, v_ok_def, oneline update_thunk_def, AllCaseEqs(), store_assign_def]) >- ( Cases_on ‘op’ \\ full_simp_tac (srw_ss()) [] \\ Cases_on ‘t'’ \\ full_simp_tac (srw_ss()) [AllCaseEqs()] \\ gvs [] - \\ drule_all_then (qspec_then ‘"f"’ assume_tac) dest_thunk_ok \\ gvs []) + \\ drule_all dest_thunk_ok \\ gvs []) \\ gvs [CaseEqs ["prod", "result", "option"]] \\ dxrule_then assume_tac (iffRL EVERY_REVERSE) \\ drule_all_then assume_tac do_app_ok \\ gs [] diff --git a/compiler/repl/evaluate_skipScript.sml b/compiler/repl/evaluate_skipScript.sml index 27574e0262..11f8e8c972 100644 --- a/compiler/repl/evaluate_skipScript.sml +++ b/compiler/repl/evaluate_skipScript.sml @@ -1723,8 +1723,9 @@ Proof \\ qexists ‘fr |+ (LENGTH s.refs,LENGTH t.refs)’ \\ gvs [] \\ rpt (irule_at Any SUBMAP_REFL \\ gvs []) \\ gvs [store_alloc_def] + \\ rename1 ‘v_rel _ _ _ v y’ \\ qexistsl [‘t with refs := t.refs ++ [Thunk m y]’, - ‘s with refs := s.refs ++ [Thunk m x1]’] + ‘s with refs := s.refs ++ [Thunk m v]’] \\ gvs [state_rel_def] \\ rw [] >- ( @@ -1860,71 +1861,84 @@ Proof >- (Cases_on ‘op’ \\ gs[] \\ Cases_on ‘t'’ \\ gs[]) >- (Cases_on ‘op’ \\ gs[] \\ Cases_on ‘t'’ \\ gs[]) >- ( - gvs [AllCaseEqs(), PULL_EXISTS] - >>~ [‘dest_thunk vs s1.refs = IsThunk NotEvaluated _’] + Cases_on ‘op’ \\ gvs [] \\ Cases_on ‘t'’ \\ gvs [] + \\ qpat_x_assum ‘_ = (s1,res)’ mp_tac + \\ TOP_CASE_TAC \\ gvs [] + \\ reverse TOP_CASE_TAC \\ gvs [] >- ( - first_x_assum drule_all \\ rw [] - \\ Cases_on ‘res1’ \\ gvs [] - \\ rpt (goal_assum drule \\ gvs []) - \\ drule_all state_rel_dest_thunk \\ rw [] - \\ Cases_on ‘dest_thunk a t1.refs’ \\ gvs [thunk_rel_def, state_rel_def]) + strip_tac + \\ first_x_assum drule_all \\ rw [] \\ gvs [] + \\ qpat_x_assum ‘res_rel _ _ (Rerr _) res1’ mp_tac + \\ Cases_on ‘res1’ \\ rw [res_rel_def] + \\ metis_tac []) + \\ first_x_assum drule_all \\ strip_tac \\ gvs [] + \\ Cases_on ‘res1’ \\ gvs [res_rel_def] + \\ TOP_CASE_TAC \\ gvs [] + \\ imp_res_tac EVERY2_REVERSE + \\ drule_all state_rel_dest_thunk \\ simp [oneline thunk_rel_def] + \\ TOP_CASE_TAC \\ gvs [] + >~ [‘BadRef’] >- metis_tac [] + >~ [‘NotThunk’] >- metis_tac [] + \\ strip_tac \\ gvs [] + \\ TOP_CASE_TAC \\ gvs [] + >- (rw [] \\ gvs [] \\ metis_tac []) + \\ TOP_CASE_TAC \\ gvs [] >- ( - first_x_assum drule_all \\ rw [] - \\ Cases_on ‘res1’ \\ gvs [] - \\ ‘state_rel l fr1 ft1 fe1 (dec_clock s1) (dec_clock t1)’ - by gvs [state_rel_def, dec_clock_def] - \\ drule_all state_rel_dest_thunk \\ rw [] - \\ Cases_on ‘dest_thunk a t1.refs’ \\ gvs [thunk_rel_def] - \\ last_x_assum $ drule_then $ qspec_then ‘sing_env "f" v'’ mp_tac - \\ impl_tac - >- gvs [env_rel_def, ctor_rel_def, sing_env_def, nsAll2_nsBind] - \\ rw [] - \\ goal_assum $ drule_at (Pat ‘state_rel _ _ _ _ _ _’) \\ gvs [] - \\ imp_res_tac SUBMAP_TRANS \\ gvs [] \\ rw [] - >- gvs [state_rel_def] - \\ Cases_on ‘res1’ \\ gvs [] - \\ ‘fr1 ⊑ fr1'’ by gvs [] - \\ drule_all state_rel_update_thunk_NONE \\ gvs []) + strip_tac \\ gvs [] + \\ qpat_x_assum ‘v_rel _ _ _ v v'’ mp_tac + \\ gvs [do_opapp_def, AllCaseEqs(), PULL_EXISTS] + \\ rw [Once v_rel_cases] + \\ metis_tac []) + \\ Cases_on ‘do_opapp [v'; Conv NONE []]’ \\ gvs [] >- ( - first_x_assum drule_all \\ rw [] - \\ Cases_on ‘res1’ \\ gvs [] - \\ ‘state_rel l fr1 ft1 fe1 (dec_clock s1) (dec_clock t1)’ - by gvs [state_rel_def, dec_clock_def] - \\ drule_all state_rel_dest_thunk \\ rw [] - \\ Cases_on ‘dest_thunk a t1.refs’ \\ gvs [thunk_rel_def] - \\ last_x_assum $ drule_then $ qspec_then ‘sing_env "f" v'’ mp_tac - \\ impl_tac - >- gvs [env_rel_def, ctor_rel_def, sing_env_def, nsAll2_nsBind] - \\ rw [] - \\ Cases_on ‘res1’ \\ gvs [] - \\ drule_at (Pat ‘update_thunk _ _ _ = _’) state_rel_update_thunk_SOME - \\ disch_then drule_all \\ rw [] \\ gvs [] - \\ ‘fr ⊑ fr1' ∧ ft ⊑ ft1' ∧ fe ⊑ fe1'’ by ( - imp_res_tac SUBMAP_TRANS \\ gvs []) - \\ rpt (goal_assum drule \\ gvs []) - \\ qexists ‘Rval a'’ \\ gvs [state_rel_def]) + CCONTR_TAC \\ gvs [] + \\ qpat_x_assum ‘v_rel _ _ _ v v'’ assume_tac + \\ gvs [do_opapp_def, AllCaseEqs(), PULL_EXISTS] + \\ rgs [Once v_rel_cases]) + \\ Cases_on ‘x’ \\ Cases_on ‘x'’ \\ gvs [] + \\ ‘q.clock = t1.clock’ by gvs [state_rel_def] \\ gvs [] + \\ TOP_CASE_TAC \\ gvs [] + >- (rw [] \\ gvs [] \\ metis_tac []) + \\ TOP_CASE_TAC \\ gvs [] + \\ ‘state_rel l fr1 ft1 fe1 (dec_clock q) (dec_clock t1)’ + by gvs [dec_clock_def, state_rel_def] + \\ first_x_assum drule + \\ disch_then $ qspec_then ‘q''’ mp_tac + \\ impl_tac \\ gvs [] >- ( - first_x_assum drule_all \\ rw [] - \\ Cases_on ‘res1’ \\ gvs [] - \\ ‘state_rel l fr1 ft1 fe1 (dec_clock s1) (dec_clock t1)’ - by gvs [state_rel_def, dec_clock_def] - \\ drule_all state_rel_dest_thunk \\ rw [] - \\ Cases_on ‘dest_thunk a t1.refs’ \\ gvs [thunk_rel_def] - \\ last_x_assum $ drule_then $ qspec_then ‘sing_env "f" v'’ mp_tac - \\ impl_tac - >- gvs [env_rel_def, ctor_rel_def, sing_env_def, nsAll2_nsBind] - \\ rw [] - \\ Cases_on ‘res1’ \\ gvs [] - \\ ‘fr ⊑ fr1' ∧ ft ⊑ ft1' ∧ fe ⊑ fe1'’ by ( - imp_res_tac SUBMAP_TRANS \\ gvs []) - \\ rpt (goal_assum drule \\ gvs []) - \\ goal_assum $ drule_at Any \\ gvs [state_rel_def]) + qpat_x_assum ‘v_rel _ _ _ v v'’ assume_tac + \\ gvs [do_opapp_def, AllCaseEqs()] + \\ rgs [Once v_rel_cases] \\ gvs [] + \\ gvs [env_rel_def] + \\ irule nsAll2_nsBind \\ gvs [v_rel_def] + \\ gvs [semanticPrimitivesPropsTheory.build_rec_env_merge] + \\ irule nsAll2_nsAppend \\ gs [] + \\ irule nsAll2_alist_to_ns + \\ gs [EVERY2_MAP, LAMBDA_PROD, v_rel_def] + \\ rw [LIST_REL_EL_EQN, ELIM_UNCURRY, env_rel_def]) + \\ strip_tac \\ gvs [] + \\ qpat_x_assum ‘v_rel _ _ _ v v'’ assume_tac + \\ gvs [do_opapp_def] + \\ gvs [CaseEq"v", CaseEq"option", CaseEq"prod"] + \\ rgs [Once v_rel_cases] \\ gvs [] \\ ( - first_x_assum drule_all \\ rw [] - \\ Cases_on ‘res1’ \\ gvs [] - \\ rpt (goal_assum drule \\ gvs []) - \\ drule_all state_rel_dest_thunk \\ rw [] - \\ Cases_on ‘dest_thunk a t1.refs’ \\ gvs [thunk_rel_def])) + reverse TOP_CASE_TAC \\ gvs [] + >- ( + rw [] \\ gvs [] + \\ TOP_CASE_TAC \\ gvs [] + \\ metis_tac [SUBMAP_TRANS]) + \\ TOP_CASE_TAC \\ gvs [] + >- ( + rw [] \\ gvs [] + \\ TOP_CASE_TAC \\ gvs [] + \\ imp_res_tac EVERY2_REVERSE + \\ drule_all state_rel_update_thunk_NONE \\ rw [] \\ gvs [] + \\ metis_tac [SUBMAP_TRANS]) + \\ strip_tac \\ gvs [] + \\ TOP_CASE_TAC \\ gvs [] + \\ imp_res_tac EVERY2_REVERSE + \\ drule_all state_rel_update_thunk_SOME \\ rw [] \\ gvs [] + \\ metis_tac [SUBMAP_TRANS])) >- ( gvs [CaseEqs ["prod", "result", "option"], PULL_EXISTS] \\ first_x_assum (drule_all_then strip_assume_tac) From b4db0ace76bd612ea265abac42610c70ae21e643 Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Wed, 1 Oct 2025 13:20:30 +0300 Subject: [PATCH 111/112] Bring up to date with mcandidate --- misc/Holmakefile | 2 +- semantics/Holmakefile | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/misc/Holmakefile b/misc/Holmakefile index f01a823001..df0cd89120 100644 --- a/misc/Holmakefile +++ b/misc/Holmakefile @@ -1,4 +1,4 @@ -INCLUDES = $(CAKEMLDIR)/developers $(HOLDIR)/examples/machine-code/hoare-triple $(HOLDIR)/examples/fun-op-sem/lprefix_lub \ +INCLUDES = $(CAKEMLDIR)/developers $(HOLDIR)/examples/machine-code/hoare-triple $(HOLDIR)/examples/pl-semantics/lprefix_lub \ $(HOLDIR)/examples/formal-languages/context-free all: $(DEFAULT_TARGETS) README.md diff --git a/semantics/Holmakefile b/semantics/Holmakefile index 72475f54c9..26d96b954e 100644 --- a/semantics/Holmakefile +++ b/semantics/Holmakefile @@ -1,5 +1,5 @@ INCLUDES = $(HOLDIR)/examples/formal-languages/context-free\ - $(HOLDIR)/examples/fun-op-sem/lprefix_lub\ + $(HOLDIR)/examples/pl-semantics/lprefix_lub\ $(CAKEMLDIR)/developers $(CAKEMLDIR)/misc\ ffi From 37f8d56e28d00933549b81757c18b2a1ad8a4f1d Mon Sep 17 00:00:00 2001 From: Nikos Alexandris Date: Wed, 1 Oct 2025 23:56:09 +0300 Subject: [PATCH 112/112] Small fixes outside compiler --- .../backend/semantics/data_monadScript.sml | 49 ++++++++++++++++++- .../translation/dafny_compilerProgScript.sml | 4 +- .../scheme/translation/to_sexpProgScript.sml | 1 + 3 files changed, 50 insertions(+), 4 deletions(-) diff --git a/compiler/backend/semantics/data_monadScript.sml b/compiler/backend/semantics/data_monadScript.sml index 6de37fe07a..f97461f361 100644 --- a/compiler/backend/semantics/data_monadScript.sml +++ b/compiler/backend/semantics/data_monadScript.sml @@ -121,6 +121,50 @@ Definition assign_def: | Rval (v,s) => (NONE, set_var dest v (install_sfs op s)) End +Definition force_def: + force ret loc src s = + case get_var src s.locals of + | NONE => fail s + | SOME thunk_v => + (case dest_thunk thunk_v s.refs of + | BadRef => fail s + | NotThunk => fail s + | IsThunk Evaluated v => + (case ret of + | NONE => (SOME (Rval v),flush_state F s) + | SOME (dest,names) => + (case cut_env names s.locals of + | NONE => fail s + | SOME env => (NONE, set_var dest v (s with locals := env)))) + | IsThunk NotEvaluated f => + (case find_code (SOME loc) [thunk_v; f] s.code s.stack_frame_sizes of + | NONE => fail s + | SOME (args1,prog,ss) => + (case ret of + | NONE => + (if s.clock = 0 then + timeout (s with <| stack := []; locals := LN |>) + else + (case evaluate (prog, call_env args1 ss (dec_clock s)) of + | (NONE,s) => fail s + | (SOME res,s) => (SOME res,s))) + | SOME (dest,names) => + (case cut_env names s.locals of + | NONE => fail s + | SOME env => + let s1 = call_env args1 ss (push_env env F (dec_clock s)) in + if s.clock = 0 then + timeout (s1 with <| stack := []; locals := LN |>) + else + (case evaluate (prog, s1) of + | (SOME (Rval x),s2) => + (case pop_env s2 of + | NONE => fail s2 + | SOME s1 => (NONE, set_var dest x s1)) + | (NONE,s) => fail s + | res => res))))) +End + Overload ":≡" = ``assign`` val _ = set_fixity ":≡" (Infixl 480); @@ -157,6 +201,7 @@ Definition to_shallow_def: to_shallow (Assign n op vars cutset) = assign n (op, vars, cutset) /\ to_shallow (Seq p1 p2) = bind (to_shallow p1) (to_shallow p2) /\ to_shallow (Return n) = return n /\ + to_shallow (Force ret loc src) = force ret loc src /\ to_shallow (Call NONE dest args NONE) = tailcall dest args /\ to_shallow (Call NONE dest args (SOME x)) = fail /\ to_shallow (Call (SOME ret) dest args handler) = call ret dest args handler /\ @@ -194,7 +239,9 @@ Proof >- (fs [get_var_def] \\ rw [] \\ CASE_TAC \\ fs [call_env_def,fromList_def]) (* Tick *) - \\ rw[tick_def,timeout_def,call_env_def,state_component_equality,fromList_def] + >- rw[tick_def,timeout_def,call_env_def,state_component_equality,fromList_def] + (* Force *) + >- rw [force_def, timeout_def] QED Overload monad_unitbind[local] = ``bind`` diff --git a/compiler/dafny/translation/dafny_compilerProgScript.sml b/compiler/dafny/translation/dafny_compilerProgScript.sml index 2c7914bf73..236a89cfa0 100644 --- a/compiler/dafny/translation/dafny_compilerProgScript.sml +++ b/compiler/dafny/translation/dafny_compilerProgScript.sml @@ -41,9 +41,6 @@ val _ = use_string_type false; val r = translate simpleSexpParseTheory.escape_string_def; val _ = use_string_type true; -val r = translate fromSexpTheory.encode_bool_def; -val r = translate fromSexpTheory.decode_bool_def; - Theorem num_to_dec_string_v_thm: (NUM --> HOL_STRING_TYPE) toString ^(IntProgTheory.tostring_v_thm |> concl |> rand) Proof @@ -230,6 +227,7 @@ val r = translate fromSexpTheory.optsexp_def; val r = translate fromSexpTheory.idsexp_def; val r = translate fromSexpTheory.typesexp_def; val r = translate fromSexpTheory.patsexp_def; +val r = translate fromSexpTheory.encode_thunk_mode_def; (* TODO 101 automatically added string IMPLODEs *) val r = translate fromSexpTheory.opsexp_def; val r = translate fromSexpTheory.lopsexp_def; diff --git a/compiler/scheme/translation/to_sexpProgScript.sml b/compiler/scheme/translation/to_sexpProgScript.sml index 3c765f8087..f7225605e2 100644 --- a/compiler/scheme/translation/to_sexpProgScript.sml +++ b/compiler/scheme/translation/to_sexpProgScript.sml @@ -34,6 +34,7 @@ val r = translate fromSexpTheory.optsexp_def; val r = translate fromSexpTheory.idsexp_def; val r = translate fromSexpTheory.typesexp_def; val r = translate fromSexpTheory.patsexp_def; +val r = translate fromSexpTheory.encode_thunk_mode_def; val r = translate fromSexpTheory.opsexp_def; val r = translate fromSexpTheory.lopsexp_def; val r = translate fromSexpTheory.expsexp_def;