From a629bf6025d24c3a989487c3e2bd4d1109201219 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:26 +0100 Subject: [PATCH 01/46] Honor explicit Isabelle heap directory overrides `ISABELLE_HEAPS_OVERRIDE` takes precedence over the configurable heap base and suffix in the recommended Isabelle settings, but the Makefile only checked and reported the suffix. It therefore warned for an already isolated worktree and could display a heap directory Isabelle would not use. This commit documents the required `etc/settings` setup and mirrors its precedence in the worktree diagnostics. An explicit override selects the exact heap directory; otherwise `ISABELLE_HEAP_BASE` replaces the default base and `ISABELLE_HEAP_SUFFIX` is appended. Signed-off-by: Hanno Becker --- ip/README.md | 46 +++++++++++++++++++++++++++++----------------- 1 file changed, 29 insertions(+), 17 deletions(-) diff --git a/ip/README.md b/ip/README.md index cf167c5d..a9e82e34 100644 --- a/ip/README.md +++ b/ip/README.md @@ -164,22 +164,30 @@ heap storage. As a remedy, you can consider putting the following in your local `etc/settings`: ``` -if [ -n "$ISABELLE_HEAP_BASE" ]; then - ISABELLE_HEAPS="$ISABELLE_HEAP_BASE/heaps" -fi - -if [ -n "$ISABELLE_HEAP_SUFFIX" ]; then - ISABELLE_HEAPS="$ISABELLE_HEAPS-$ISABELLE_HEAP_SUFFIX" +if [ -n "$ISABELLE_HEAPS_OVERRIDE" ]; then + ISABELLE_HEAPS="$ISABELLE_HEAPS_OVERRIDE" +else + if [ -n "$ISABELLE_HEAP_BASE" ]; then + ISABELLE_HEAPS="$ISABELLE_HEAP_BASE/heaps" + fi + + if [ -n "$ISABELLE_HEAP_SUFFIX" ]; then + ISABELLE_HEAPS="$ISABELLE_HEAPS-$ISABELLE_HEAP_SUFFIX" + fi fi ``` -With this, if you set the environment variable `ISABELLE_HEAP_SUFFIX` prior to starting Isabelle, -then the provided suffix will be added to the default heap directory. For example, with -`ISABELLE_HEAP_SUFFIX=A`, heaps will be looked up and stored in `$ISABELLE_HOME_USER/heaps-A` -instead of the default `$ISABELLE_HOME_USER/heaps`. +`ISABELLE_HEAPS_OVERRIDE` selects an exact heap directory and takes precedence over both +`ISABELLE_HEAP_BASE` and `ISABELLE_HEAP_SUFFIX`. + +Without an override, setting `ISABELLE_HEAP_SUFFIX` prior to starting Isabelle adds the provided +suffix to the selected heap directory. For example, with `ISABELLE_HEAP_SUFFIX=A`, heaps will be +looked up and stored in `$ISABELLE_HOME_USER/heaps-A` instead of the default +`$ISABELLE_HOME_USER/heaps`. If you even want to change the base directory to something other than `$ISABELLE_HOME_USER`, the -above would allow you to do so by setting `$ISABELLE_HEAP_BASE`. +above allows you to do so by setting `$ISABELLE_HEAP_BASE`, unless +`ISABELLE_HEAPS_OVERRIDE` is set. This allows you to maintain multiple heap stores and manually switch between them. In particular, when working with multiple worktrees, you could use different heap stores per @@ -242,12 +250,16 @@ Only timings recorded by Isabelle are included. * Add the following to your local `etc/settings` (e.g. `~/.isabelle/Isabelle2025-2/etc/settings`): ``` -if [ -n "$ISABELLE_HEAP_BASE" ]; then - ISABELLE_HEAPS="$ISABELLE_HEAP_BASE/heaps" -fi - -if [ -n "$ISABELLE_HEAP_SUFFIX" ]; then - ISABELLE_HEAPS="$ISABELLE_HEAPS-$ISABELLE_HEAP_SUFFIX" +if [ -n "$ISABELLE_HEAPS_OVERRIDE" ]; then + ISABELLE_HEAPS="$ISABELLE_HEAPS_OVERRIDE" +else + if [ -n "$ISABELLE_HEAP_BASE" ]; then + ISABELLE_HEAPS="$ISABELLE_HEAP_BASE/heaps" + fi + + if [ -n "$ISABELLE_HEAP_SUFFIX" ]; then + ISABELLE_HEAPS="$ISABELLE_HEAPS-$ISABELLE_HEAP_SUFFIX" + fi fi if [ -n "$ISABELLE_PROJECT_BASE" ]; then From bc81b2938834e048e740c4d3ad1b430c8c64e494 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:26 +0100 Subject: [PATCH 02/46] Crush: Skip inactive callback-free timers TIME, TIME', TIME_pos, and TIME_pos' entered TIME_CB whenever their local flag was enabled, even if global Crush timing was disabled. The callback-free wrappers therefore measured tactic sequences only to discard the result. Gate these helpers on both flags and return the identity otherwise. Leave TIME_CB and TIME_CB' unchanged so callback users such as the step timeout still run when timing reports are disabled. Signed-off-by: Hanno Becker --- Crush/time.ML | 27 +++++++++++++++++++++++---- 1 file changed, 23 insertions(+), 4 deletions(-) diff --git a/Crush/time.ML b/Crush/time.ML index caa70c54..b05ba873 100644 --- a/Crush/time.ML +++ b/Crush/time.ML @@ -301,17 +301,36 @@ struct end val TIME : Proof.context -> bool -> string -> tactic -> tactic = - fn ctxt => fn enabled => fn msg => TIME_CB ctxt Position.none enabled msg default_logger (K (K (K (K ())))) + fn ctxt => fn enabled => + if enabled andalso Config.get ctxt timing_enabled then + fn msg => TIME_CB ctxt Position.none true msg default_logger + (K (K (K (K ())))) + else + K I val TIME' : Proof.context -> bool -> string -> (int -> tactic) -> (int -> tactic) = - fn ctxt => fn enabled => if not enabled then K I else fn msg => fn t => TIME ctxt true msg o t + fn ctxt => fn enabled => + if enabled andalso Config.get ctxt timing_enabled then + fn msg => fn t => TIME_CB ctxt Position.none true msg default_logger + (K (K (K (K ())))) o t + else + K I val TIME_pos : Proof.context -> Position.T -> bool -> string -> logger -> tactic -> tactic = - fn ctxt => fn pos => fn enabled => fn msg => fn log => TIME_CB ctxt pos enabled msg log (K (K (K (K ())))) + fn ctxt => fn pos => fn enabled => + if enabled andalso Config.get ctxt timing_enabled then + fn msg => fn log => TIME_CB ctxt pos true msg log + (K (K (K (K ())))) + else + K (K I) val TIME_pos' : Proof.context -> Position.T -> bool -> string -> logger -> (int -> tactic) -> (int -> tactic) = fn ctxt => fn pos => fn enabled => - if not enabled then K (K I) else fn msg => fn log => fn t => TIME_pos ctxt pos true msg log o t + if enabled andalso Config.get ctxt timing_enabled then + fn msg => fn log => fn t => TIME_CB ctxt pos true msg log + (K (K (K (K ())))) o t + else + K (K I) fun TIME_CB' (ctxt: Proof.context) (pos: Position.T) (enabled: bool) : string From a1185c406ec1a6997e3f025bb714ba5175d1b15b Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:26 +0100 Subject: [PATCH 03/46] Crush: Reuse the ucincl discharge solver crush_step_tac_frame prepares ucincl_discharge_tac once per Crush invocation, but the returned closure rebuilt ucincl_solve_tac whenever it was applied to the freshly decorated per-step tactic. Prepare the context-dependent solver before returning the closure. This reuses theorem lookup, simp-context setup, and tactic decoration across all Crush steps while retaining the same proof context. Signed-off-by: Hanno Becker --- Crush/seplog.ML | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Crush/seplog.ML b/Crush/seplog.ML index 9b41664c..538065a5 100644 --- a/Crush/seplog.ML +++ b/Crush/seplog.ML @@ -1104,7 +1104,8 @@ struct end val ucincl_discharge_tac : Proof.context -> (int -> tactic) -> (int -> tactic) = fn ctxt => - fn ct => ct THEN_ALL_NEW (TRY o (ucincl_solve_tac ctxt)) + let val solve = ucincl_solve_tac ctxt + in fn ct => ct THEN_ALL_NEW (TRY o solve) end val ucincl_discharge_tac' : (Proof.context -> int -> tactic) -> (Proof.context -> int -> tactic) = fn ct => fn ctxt => ct ctxt THEN_ALL_NEW (TRY o (ucincl_solve_tac ctxt)) From 1d995ccc64a6401760c562ccbb772eeff39c7ab8 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:27 +0100 Subject: [PATCH 04/46] Crush: Prepare the mandatory ucincl solver once ucincl_must_discharge_tac constructed its context-dependent solver below the child-tactic argument. This prevented a partially applied wrapper from sharing the setup and differed from ucincl_discharge_tac. Move solver construction into the proof-context closure. Existing immediate call sites still construct it once; callers that retain the partially applied wrapper can now reuse it. Signed-off-by: Hanno Becker --- Crush/seplog.ML | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Crush/seplog.ML b/Crush/seplog.ML index 538065a5..f9cb386c 100644 --- a/Crush/seplog.ML +++ b/Crush/seplog.ML @@ -1111,7 +1111,8 @@ struct fn ct => fn ctxt => ct ctxt THEN_ALL_NEW (TRY o (ucincl_solve_tac ctxt)) val ucincl_must_discharge_tac : Proof.context -> (int -> tactic) -> (int -> tactic) = fn ctxt => - fn ct => ct THEN_ALL_NEW (IF_OK' is_ucincl (SOLVED' (ucincl_solve_tac ctxt))) + let val solve = ucincl_solve_tac ctxt + in fn ct => ct THEN_ALL_NEW (IF_OK' is_ucincl (SOLVED' solve)) end val ucincl_must_discharge_tac' : (Proof.context -> int -> tactic) -> (Proof.context -> int -> tactic) = fn ct => fn ctxt => ct ctxt THEN_ALL_NEW (IF_OK' is_ucincl (SOLVED' (ucincl_solve_tac ctxt))) From 70f6e94f14527d5388aaf484c510ef6b7482772f Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:27 +0100 Subject: [PATCH 05/46] Crush: Avoid disabled REPEAT_SMART diagnostics REPEAT_SMART assembled step and worklist messages before debug checked its configuration. Since debugging is disabled by default, every step paid for integer conversion, list rendering, and concatenation without emitting the result. Cache the debug level per invocation and accept message thunks so formatting happens only when the corresponding level is enabled. Signed-off-by: Hanno Becker --- Crush/tacticals.ML | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/Crush/tacticals.ML b/Crush/tacticals.ML index 6c90ed02..d7cbe597 100644 --- a/Crush/tacticals.ML +++ b/Crush/tacticals.ML @@ -297,7 +297,8 @@ struct fun REPEAT_SMART (ctxt : Proof.context) (log : logger) (aggressive : bool) (m : logger -> tactic) : tactic = let - fun debug lvl = if lvl <= (Config.get ctxt Crush_Config.debug_level) then tracing else K () + val debug_level = Config.get ctxt Crush_Config.debug_level + fun debug lvl msg = if lvl <= debug_level then tracing (msg ()) else () val prioritize_changed_goals = Config.get ctxt Crush_Config.prioritize_changed_goals val m = if Config.get ctxt Crush_Config.do_big_steps then DWELL o m else m val gas = Config.get ctxt Crush_Config.gas @@ -334,10 +335,11 @@ struct val log' = fn pp => [Pretty.enclose "[" "]" [count |> Int.toString |> Pretty.str], Pretty.brk 1, pp] |> Pretty.block |> log - val _ = "step: " ^ (count |> Int.toString) ^ ", " ^ + val _ = debug 0 (fn () => + "step: " ^ (count |> Int.toString) ^ ", " ^ "goal: " ^ (i |> Int.toString) ^ ", " ^ "goals: " ^ (st |> Thm.nprems_of |> Int.toString) ^ ", " ^ - "worklist: " ^ (intlist_to_string is) |> debug 0 + "worklist: " ^ (intlist_to_string is)) val (st, is) = rotate_goal_adjust_indices i (st, is) val (res, abort) = ((m log' st |> Seq.pull, false) handle SMART _ => (NONE, true)) in if abort then (error ("inner tactic raised stop exception at step " ^ (Int.toString count)); @@ -382,11 +384,11 @@ struct else (range_of_nats_base 1 (n_new_goals+1)) @ changed @ is' - val _ = "Goals before: " ^ (nprems_old |> Int.toString) |> debug 1 - val _ = "Goals after: " ^ (nprems_new |> Int.toString) |> debug 1 - val _ = "Worklist: " ^ (intlist_to_string is) |> debug 1 - val _ = "Worklist shifted: " ^ (intlist_to_string is') |> debug 1 - val _ = "New worklist: " ^ (intlist_to_string is'') |> debug 1 + val _ = debug 1 (fn () => "Goals before: " ^ (nprems_old |> Int.toString)) + val _ = debug 1 (fn () => "Goals after: " ^ (nprems_new |> Int.toString)) + val _ = debug 1 (fn () => "Worklist: " ^ (intlist_to_string is)) + val _ = debug 1 (fn () => "Worklist shifted: " ^ (intlist_to_string is')) + val _ = debug 1 (fn () => "New worklist: " ^ (intlist_to_string is'')) in SOME ((st', true), run_smart (count+1) st' is'') end @@ -572,4 +574,4 @@ val _ = (fn st => Toplevel.actual_proof (fn prf => (report_back (); proof_node_step st prf)) o Toplevel.skip_proof report_back)); -in end \ No newline at end of file +in end From ee044639a173be921c680addb6b58c610a629ea5 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:27 +0100 Subject: [PATCH 06/46] Crush: Reuse premise lists in REPEAT_SMART Subgoal change detection called Thm.prems_of on both the old and new proof state for every compared goal pair. A successful step can compare several unaffected goals, repeating the same proof-state traversal. Extract both premise lists once per successful step and reuse them for the existing aeconv comparisons. Worklist ordering and change detection remain unchanged. Signed-off-by: Hanno Becker --- Crush/tacticals.ML | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/Crush/tacticals.ML b/Crush/tacticals.ML index d7cbe597..aa872ca6 100644 --- a/Crush/tacticals.ML +++ b/Crush/tacticals.ML @@ -305,13 +305,6 @@ struct fun error msg = msg |> tracing - fun subgoals_have_changed st st' (i,j) = - let val goal_i = List.nth (Thm.prems_of st, i-1) - val goal_j = List.nth (Thm.prems_of st', j-1) - in - not (Envir.aeconv (goal_i, goal_j)) - end - fun rotate_goal_adjust_indices i (st, is) = if i = 1 then (st, is) else let @@ -371,10 +364,18 @@ struct val nprems_old = Thm.nprems_of st val nprems_new = Thm.nprems_of st' val n_new_goals = nprems_new - nprems_old + val prems_old = Thm.prems_of st + val prems_new = Thm.prems_of st' + fun subgoal_has_changed (i, j) = + let val goal_i = List.nth (prems_old, i-1) + val goal_j = List.nth (prems_new, j-1) + in + not (Envir.aeconv (goal_i, goal_j)) + end val not_is_old = filter (list_contains_not is) (range_of_nats_base 2 (nprems_old-1)) val not_is_new = insert_goals_adjust_idxs n_new_goals not_is_old val changed = (not_is_old, not_is_new) |> op ~~ - |> List.filter (subgoals_have_changed st st') |> List.map snd + |> List.filter subgoal_has_changed |> List.map snd (* Add inserted subgoals to worklist *) val is' = insert_goals_adjust_idxs n_new_goals is From 9f6bf0a900412c93950ce1180545946635e95409 Mon Sep 17 00:00:00 2001 From: Lawrence Paulson Date: Thu, 24 Sep 2026 17:48:27 +0100 Subject: [PATCH 07/46] Misc: Add generic set, list, and multiset facts Downstream developments repeatedly reproved the same small facts about `find`, multiset inclusion, and set disjointness, and two multiset elimination rules were declared `[elim]` even though their conclusion is a free variable, so they never fired automatically. Add `find_Some_iff_distinct` to `ListAdditional`, `in_not_in_disjoint` to `SetAdditional`, and `distinct_subset_mset_set`, `distinct_from_sublist`, and `mset_take_submset [simp]` to `MultisetAdditional`. Promote `mset_set_minus_singletonE` and `mset_range_minus_singletonE` to `[elim!]`; both discharge an arbitrary goal from a contradictory premise, so eager application is safe. Signed-off-by: Lawrence Paulson --- Misc/ListAdditional.thy | 6 ++++++ Misc/MultisetAdditional.thy | 27 +++++++++++++++++++++++++-- Misc/SetAdditional.thy | 6 ++++++ 3 files changed, 37 insertions(+), 2 deletions(-) diff --git a/Misc/ListAdditional.thy b/Misc/ListAdditional.thy index 3a6c20d6..40fbaf0c 100644 --- a/Misc/ListAdditional.thy +++ b/Misc/ListAdditional.thy @@ -553,6 +553,12 @@ lemma sorted_wrt_on_map: shows \sorted_wrt_on P I (list.map f xs) = sorted_wrt_on (\x y. P (f x) (f y)) (I \ f) xs\ by (simp add: sorted_wrt_on_def) +lemma find_Some_iff_distinct: + assumes \distinct (list.map f xs)\ + shows \(find (\ l. f l = n) xs = Some x) = (\i xs ! i = x)\ + using assms[simplified distinct_conv_nth] + by (auto simp add: find_Some_iff) + (*<*) end (*>*) \ No newline at end of file diff --git a/Misc/MultisetAdditional.thy b/Misc/MultisetAdditional.thy index 78b66eea..01972aa6 100644 --- a/Misc/MultisetAdditional.thy +++ b/Misc/MultisetAdditional.thy @@ -108,7 +108,7 @@ lemma mapped_multiset_eq [mset_simps]: shows \{# \ . ms #} = {# \ . ms #}\ using assms by (metis multiset.map_cong) -lemma mset_set_minus_singletonE [elim]: +lemma mset_set_minus_singletonE [elim!]: assumes \i \# mset_set s - {#i#}\ shows \R\ proof - @@ -122,7 +122,7 @@ proof - by auto qed -lemma mset_range_minus_singletonE [elim]: +lemma mset_range_minus_singletonE [elim!]: assumes \i \# mset [0.. shows \R\ using assms Multiset.mset_upt mset_set_minus_singletonE by auto @@ -476,6 +476,29 @@ proof - by (auto simp: multiset_eq_iff count_mset_set') qed +subsection\Distinctness from multiset inclusion\ + +lemma distinct_subset_mset_set: + assumes \mset ys \# mset_set X\ + and \finite X\ + shows \distinct ys\ + using assms + apply (induction ys, simp) + apply (auto simp add: subseteq_mset_def count_mset_set') + subgoal by (auto split: if_splits) + by (metis (full_types) nat_le_linear not_less_eq_eq) + +lemma distinct_from_sublist: + assumes \distinct xs\ + and \mset ys \# mset xs\ + shows \distinct ys\ + using assms + by (auto simp add: mset_set_set intro!: distinct_subset_mset_set[where X=\set xs\]) + +lemma mset_take_submset [simp]: + shows \mset (take i xs) \# mset xs\ + by (metis append_take_drop_id mset_subset_eq_add_right union_code union_commute) + (*<*) end (*>*) \ No newline at end of file diff --git a/Misc/SetAdditional.thy b/Misc/SetAdditional.thy index 2e34009d..4dbf897d 100644 --- a/Misc/SetAdditional.thy +++ b/Misc/SetAdditional.thy @@ -128,6 +128,12 @@ lemma in_set_cons: shows \(x \ set (Cons y zs)) = (x = y \ x \ set zs)\ by auto +lemma in_not_in_disjoint: + assumes \x \ A\ + and \A \ B = {}\ + shows \x \ B\ + using assms by blast + (*<*) end (*>*) \ No newline at end of file From a7a5b4a5fdd8c74e55174425df33e725c95fe038 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:28 +0100 Subject: [PATCH 08/46] AutoCorrode: Derive locality rewrites on demand AutoLocality eagerly materialized pairwise commutativity and cancellation theorems and coupled semantic registrations to physical simprocs. Setup grew quadratically, locale replay duplicated dispatchers, and cancellation repeatedly traversed large update telescopes. Keep certificate bundles in one structural operational-key map and use theorem-free secondary indexes to rank candidates before loading payloads. Derive only requested kernel rewrites in the invocation context and retain no process-global theorem cache. Install one generic simproc per rigid constant and arity family through standard local declarations. Transport both layers through morphisms, merge them symmetrically, and reactivate a local representative only when restricted simplification removes it. Structural lambda heads remain semantic-only. Construct cancellation with bounded recursive conversions, relative attribute indexes, root scheduling, and exact adjacent swaps through record zippers. Invocation-local typed memoization avoids rescanning buried telescope bodies without retaining theorems globally. Add lifecycle, locale, merge-diamond, polymorphism, shape, instrumentation, stress, and Crush regressions. The wide buried-update case falls from 11.715 seconds to 0.026 seconds. Signed-off-by: Hanno Becker --- Autogen/AutoCommon.thy | 55 +- Autogen/AutoLens.thy | 72 +- Autogen/AutoLocality.thy | 5440 +++++++++++++++-- Autogen/AutoLocality_Instrumentation.ML | 948 +++ Autogen/AutoLocality_Test0.thy | 177 - Autogen/AutoLocality_Test1.thy | 31 - Autogen/AutoLocality_Test2.thy | 23 - .../AutoLocality_B0_All.thy | 33 + .../AutoLocality_B0_Automation.thy | 81 + .../AutoLocality_B0_Base.thy | 168 + .../AutoLocality_B0_Conflict_Base.thy | 38 + .../AutoLocality_B0_Conflict_Left.thy | 29 + .../AutoLocality_B0_Conflict_Right.thy | 34 + .../AutoLocality_B0_Crush_All.thy | 23 + .../AutoLocality_B0_Diamond_Base.thy | 35 + .../AutoLocality_B0_Diamond_LR.thy | 35 + .../AutoLocality_B0_Diamond_Left.thy | 30 + .../AutoLocality_B0_Diamond_RL.thy | 35 + .../AutoLocality_B0_Diamond_Right.thy | 30 + .../AutoLocality_B0_Lifecycle.thy | 366 ++ .../AutoLocality_B0_Reentry.thy | 26 + .../AutoLocality_B0_Traversal.thy | 223 + .../AutoLocality_B0_Types.thy | 249 + .../AutoLocality_C1_Counters.thy | 680 +++ .../AutoLocality_C1_Instrumentation.thy | 393 ++ .../AutoLocality_C1_Locale_Retention.thy | 284 + .../AutoLocality_Tests/AutoLocality_Test3.thy | 212 + .../AutoLocality_Test_Boundaries.thy | 888 +++ .../AutoLocality_Test_Cancel.thy | 122 + .../AutoLocality_Test_Common.thy | 239 + .../AutoLocality_Test_Contexts.thy | 309 + .../AutoLocality_Test_Diamond.thy | 120 + .../AutoLocality_Test_Diamond_Base.thy | 30 + .../AutoLocality_Test_Diamond_Left.thy | 21 + .../AutoLocality_Test_Diamond_Right.thy | 21 + .../AutoLocality_Test_Errors.thy | 72 + .../AutoLocality_Test_Linear.thy | 84 + .../AutoLocality_Test_Locale.thy | 546 ++ .../AutoLocality_Test_Matrix.thy | 199 + .../AutoLocality_Test_Matrix_Locale.thy | 112 + .../AutoLocality_Test_Perf.thy | 167 + .../AutoLocality_Test_Polymorphic.thy | 351 ++ .../AutoLocality_Test_Record_Extension.thy | 75 + .../AutoLocality_Test_Shapes.thy | 140 + .../AutoLocality_Test_Shapes_Wide.thy | 225 + .../AutoLocality_Test_Wide.thy | 297 + Autogen/Autogen.thy | 8 +- Autogen/README.md | 496 ++ Autogen/ROOT | 37 +- Makefile | 14 +- README.md | 7 +- tutorial/Tutorial_HoareWorked.thy | 4 +- 52 files changed, 13452 insertions(+), 882 deletions(-) create mode 100644 Autogen/AutoLocality_Instrumentation.ML delete mode 100644 Autogen/AutoLocality_Test0.thy delete mode 100644 Autogen/AutoLocality_Test1.thy delete mode 100644 Autogen/AutoLocality_Test2.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_B0_All.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_B0_Automation.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_B0_Base.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_B0_Conflict_Base.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_B0_Conflict_Left.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_B0_Conflict_Right.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_B0_Crush_All.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_B0_Diamond_Base.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_B0_Diamond_LR.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_B0_Diamond_Left.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_B0_Diamond_RL.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_B0_Diamond_Right.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_B0_Lifecycle.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_B0_Reentry.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_B0_Traversal.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_B0_Types.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_C1_Counters.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_C1_Instrumentation.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_C1_Locale_Retention.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test3.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Boundaries.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Cancel.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Common.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Contexts.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Diamond.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Diamond_Base.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Diamond_Left.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Diamond_Right.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Errors.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Linear.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Locale.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Matrix.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Matrix_Locale.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Perf.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Polymorphic.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Record_Extension.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Shapes.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Shapes_Wide.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Wide.thy create mode 100644 Autogen/README.md diff --git a/Autogen/AutoCommon.thy b/Autogen/AutoCommon.thy index fdd65d2b..89d28f40 100644 --- a/Autogen/AutoCommon.thy +++ b/Autogen/AutoCommon.thy @@ -7,14 +7,48 @@ begin ML\ \\Trace level: The higher, the more verbose the logging gets\ - val locality_trace_level = Attrib.setup_config_int @{binding "locality_trace_level"} (K 1) + val locality_trace_level = Attrib.setup_config_int @{binding "locality_trace_level"} (K 0) - \\Log text at given debug level; will be dropped if larger than \<^verbatim>\locality_trace_level\.\ - fun locality_pretty_trace ctxt lvl = - if lvl <= Config.get ctxt locality_trace_level then - Pretty.string_of #> tracing - else - K () + \\Construct and log text at the given debug level only when tracing is enabled. + Level zero disables tracing; positive levels retain the existing verbosity ordering.\ + fun locality_pretty_trace ctxt lvl (pretty : unit -> Pretty.T) = + let val trace_level = Config.get ctxt locality_trace_level in + if 0 < trace_level andalso lvl <= trace_level + then pretty () |> Pretty.string_of |> tracing + else () + end + + \\Authoritative invocation-context switch for AutoLocality cancellation simprocs.\ + val locality_cancel_enabled = + Attrib.setup_config_bool @{binding "locality_cancel_enabled"} (K true) + + \\When set, the locality commands report how long each generated sub-proof takes. This is a + diagnostic for spotting which phase (commutativity / disjointness / local-action) dominates, + independent of the verbosity governed by \<^verbatim>\locality_trace_level\.\ + val locality_timing = Attrib.setup_config_bool @{binding "locality_timing"} (K false) + + \\Time a thunk and, if \<^verbatim>\locality_timing\ is set, report the elapsed time under \<^verbatim>\label\.\ + fun locality_time ctxt (label : string) (f : unit -> 'a) : 'a = + if Config.get ctxt locality_timing then + let + val timer = Timing.start () + val result = f () + val _ = tracing ("[locality timing] " ^ label ^ ": " ^ Timing.message (Timing.result timer)) + in result end + else f () + + \\As \<^verbatim>\locality_time\, but for a tactic. The tactic's result sequence is forced eagerly so the + measurement captures the real proof-search cost rather than the (lazy) construction of the + sequence. The generated goals are deterministic (at most one result), so forcing is safe.\ + fun locality_time_tac ctxt (label : string) (tac : tactic) : tactic = + if Config.get ctxt locality_timing then + (fn st => + let + val timer = Timing.start () + val results = Seq.list_of (tac st) + val _ = tracing ("[locality timing] " ^ label ^ ": " ^ Timing.message (Timing.result timer)) + in Seq.of_list results end) + else tac \\Lookup named theorem list by name. If it does not exist, return \<^verbatim>\NONE\. If it does, return the fully qualified name.\ @@ -30,8 +64,9 @@ ML\ NONE => let val (name', ctxt') = Named_Theorems.declare (Binding.make (name, Position.none)) "" ctxt - val _ = Pretty.text "Created named theorem list:" @ [Pretty.brk 1, Pretty.str name] - |> Pretty.block |> locality_pretty_trace ctxt 1 + val _ = locality_pretty_trace ctxt 1 (fn () => + Pretty.text "Created named theorem list:" @ [Pretty.brk 1, Pretty.str name] + |> Pretty.block) in (true, name', ctxt') end @@ -57,4 +92,4 @@ ML\ end \ -end \ No newline at end of file +end diff --git a/Autogen/AutoLens.thy b/Autogen/AutoLens.thy index 9b02376c..50b9fb92 100644 --- a/Autogen/AutoLens.thy +++ b/Autogen/AutoLens.thy @@ -142,15 +142,72 @@ ML\ \\Update the ith entry of a list\ fun list_set_nth (i : int) (x : 'a) = nth_map i (K x) - \\Looks up a datatype record in the given context, and returns the list of fields\ - fun get_fields rec_name thy = let - val ctxt = Local_Theory.target_of thy - val (ty, _) = Term.dest_Type (Proof_Context.read_type_name {proper = true, strict = false} ctxt rec_name) - val sels = hd (#selss (the (Ctr_Sugar.ctr_sugar_of ctxt ty))) in - map (fst o Term.dest_Const) sels - |> map Long_Name.base_name + \\Looks up a datatype record in the given context, and returns the list of fields (fully qualified)\ + + fun get_fields_full rec_name thy = + let + val ctxt = Local_Theory.target_of thy + val theory = Proof_Context.theory_of ctxt + val (ty, _) = + Term.dest_Type + (Proof_Context.read_type_name + {proper = true, strict = false} ctxt rec_name) + fun standard_record_hierarchy name = + let + val info = Record.the_info theory name + val parents = + (case #parent info of + NONE => [] + | SOME (_, parent_name) => + standard_record_hierarchy parent_name) + in + parents @ [info] + end + in + case Ctr_Sugar.ctr_sugar_of ctxt ty of + SOME sugar => + hd (#selss sugar) |> map (fst o Term.dest_Const) + | NONE => + (case Record.get_info theory ty of + SOME _ => + standard_record_hierarchy ty + |> maps #fields + |> map fst + | NONE => + error ("Unknown datatype or record type " ^ quote rec_name)) end + fun get_fields rec_name thy = + get_fields_full rec_name thy + |> map Long_Name.base_name + + fun extract_const_core ((Const ("_type_constraint_", _)) $ t) = extract_const_core t + | extract_const_core (Abs (_, _, t)) = extract_const_core t + | extract_const_core t = t |> Term.strip_comb |> fst |> Term.dest_Const + + val extract_const = extract_const_core #> fst + + fun field_update rec_name field = rec_name ^ "." ^ "update_" ^ field + + fun get_field_updates_full rec_name thy = + let + val ctxt = Local_Theory.target_of thy + val theory = Proof_Context.theory_of ctxt + val (ty, _) = + Term.dest_Type + (Proof_Context.read_type_name + {proper = true, strict = false} ctxt rec_name) + in + case Record.get_info theory ty of + SOME _ => get_fields_full rec_name thy |> map (suffix Record.updateN) + | NONE => + get_fields rec_name thy + |> List.map (field_update rec_name + #> Syntax.parse_term thy + #> extract_const) + end + + \\General helpers for interpreting strings as methods and applying them\ val apply_text = (Seq.the_result "initial method") oo ((fn t => (t, Position.no_range)) #> Proof.apply) val apply_method = K #> Method.Basic #> apply_text @@ -556,4 +613,3 @@ end (*<*) end (*>*) - diff --git a/Autogen/AutoLocality.thy b/Autogen/AutoLocality.thy index dc0bee40..46f9c673 100644 --- a/Autogen/AutoLocality.thy +++ b/Autogen/AutoLocality.thy @@ -3,12 +3,235 @@ theory AutoLocality imports Main - AutoCommon AutoLens - keywords "locality_lemma" "locality_autoderive" + AutoCommon + AutoLens + "HOL-Library.Datatype_Records" + keywords "locality_lemma" "locality_init" "locality_check" "print_locality_data" :: thy_goal and "footprint" :: quasi_command begin +ML_file "AutoLocality_Instrumentation.ML" + +section\Implementation guide\ + +text\ +This section documents the implementation of AutoLocality. It assumes that +the reader already knows the user-facing problem and commands; that +motivation is in \<^file>\README.md\. The implementation can be +understood backwards from its runtime entry point: + +\<^enum> the simplifier sees a term matching a locality dispatcher simproc; +\<^enum> the simproc looks up footprint metadata in the current proof context; +\<^enum> the lookup finds the footprint declaration whose record type, + function shape, record-argument position, and applied prefix match the term; +\<^enum> the cancellation planner uses the registration certificates to + construct the needed intermediate rewrites; and +\<^enum> the simproc returns one kernel-checked equality to the simplifier. + +Here, a certificate means an ordinary Isabelle theorem already proved during +registration. It justifies one local fact about the registered function: +field-update equations for an operation, disjoint field-projection equations, +or the theorem that an attribute is unchanged by updates outside its +footprint. The simproc combines these stored theorems to construct and prove +the larger rewrite returned to the simplifier. + +The important design choice is that the theory stores footprint metadata and +these per-registration certificate theorems, not a theorem for every possible +pair of operations. Pairwise commutativity and cancellation theorems are +derived only when a concrete simplifier invocation needs them. +\ + +subsection\Runtime architecture\ + +text\ +An operation changes a record and an attribute observes a record. Both are +registered with a footprint. The registration command is the declaration-time +front end; the cancellation simproc is the runtime back end. + +The runtime path is: + +\<^enum> A declaration creates a typed \<^verbatim>\locality_entry\. It contains + the canonical operational key, the constant and record identities, the + footprint, record-field metadata, and the certificate the declaration + proved. +\<^enum> The entry is inserted into the proof context. The context also receives + secondary indexes containing only operational keys, never theorem payloads. +\<^enum> The declaration ensures that the relevant generic dispatcher simproc + exists in the local simpset. A dispatcher is selected by the head constant + and its full application arity. +\<^enum> During simplification, Isabelle invokes that dispatcher only for its + syntactic trigger. The dispatcher receives the current proof context and + the matched certified term. +\<^enum> The dispatcher ranks and validates candidates, plans hoisting and + cancellation, proves the resulting equality, and returns the theorem as a + rewrite. If the term is malformed or no safe rewrite applies, it returns + \<^verbatim>\NONE\. + +Thus the simpset contains small pattern-triggered ML procedures, while the +proof context contains the data those procedures consult. The simpset does +not contain a quadratic table of pre-generated pairwise theorems. +\ + +subsection\Proof-context storage\ + +text\ +The following are the main persistent storage entities. + +\<^enum> \<^verbatim>\RecordLocalityData\ is the authoritative + \<^verbatim>\Generic_Data\ table. Its key is a structural + \<^verbatim>\locality_operational_key\; its value is the complete + \<^verbatim>\locality_entry\, including certificates. +\<^enum> \<^verbatim>\LocalitySecondaryIndex\ is a second + \<^verbatim>\Generic_Data\ value. Its + \<^verbatim>\locality_secondary_index\ contains record indexes, + constant-name indexes, replay-slot indexes, family paths, and dispatcher + paths. These tables store key sets only. A selected key is resolved through + \<^verbatim>\RecordLocalityData\. +\<^enum> \<^verbatim>\LocalityDispatcherInventory\ is a third + \<^verbatim>\Generic_Data\ value. It records which local named simproc + belongs to each dispatcher family. It stores the source name, a canonical + alias, and an origin stamp, but no theorem payload. +\<^enum> The named theorem bundles created for each record contain the + declaration-time field facts and certificates used by the proof routines. + They are ordinary proof-context theorem collections, not a replacement for + the typed registry. + +The operational key records the dimensions needed for safe lookup: record +type, entry kind, canonical typed pattern, flexible-prefix information, +partial-application depth, and record-argument slot. This prevents a +polymorphic or locale-flexible registration from using another registration's +certificates. +\ + +subsection\Registration and simpset lifecycle\ + +text\ +Registration first proves the footprint claim. A footprint is the list of +record fields that the function may read or change. For an operation, the +registration produces ordinary Isabelle theorem certificates for field +updates, field commutation, and disjoint projection. For an attribute, it +produces the theorem that updates outside the footprint do not change the +attribute's result. If these proofs do not close, the entry is not installed. + +After the entry is stored, the declaration computes its dispatcher family. +Attribute dispatchers are keyed by the head constant and full application +arity. The command creates one generic simproc with a generated, stable +name, then records that name in \<^verbatim>\LocalityDispatcherInventory\. +The procedure closes over only its dispatcher key; it reads registrations +from the invocation's proof context. + +The default simplifier contains the local dispatchers. The +\<^verbatim>\locality_no_cancel\ attribute changes the configuration +flag \<^verbatim>\locality_cancel_enabled\ to false. The +\<^verbatim>\locality_cancel\ attribute sets it to true and restores any +missing local dispatcher procedures to the current simpset. This restoration +is needed because \<^verbatim>\simp only\ starts from a restricted simpset +and removes ambient procedures. The attribute checks that each expected +dispatcher is present exactly once and has the expected trigger family. + +Locale interpretation and context merge transport the registry, indexes, +and dispatcher inventory as proof-context data. Merging equal registrations +chooses a deterministic representative. Merging incompatible entries or +independently allocated dispatcher families raises an error. No process-global +simpset or theorem cache is used. +\ + +subsection\How the simproc derives a cancellation rewrite\ + +text\ +The main callback is +\<^verbatim>\locality_cancellation_simproc_for_dispatch\. Its input is a +term at the simproc's syntactic trigger. The callback performs these steps: + +\<^enum> It checks the configuration flag and obtains the invocation-local + instrumentation/counter handle. +\<^enum> It extracts the term head and arguments and queries the dispatcher + paths for registrations with the matching record, entry kind, head, arity, + record slot, and partial-application depth. +\<^enum> It applies the ranking policy: exact typed entries precede + polymorphic entries, rigid prefixes precede flexible prefixes, and longer + prefixes precede shorter prefixes. Lower ranks are ignored once a valid + candidate exists at a higher rank. Incompatible candidates at the winning + rank are an error. +\<^enum> It decomposes the record argument into the attribute and its nested + operation telescope. It identifies operations that are disjoint from the + attribute and can cross every operation between them. +\<^enum> It derives adjacent commutativity rewrites only for the swaps needed + by that telescope. It then constructs the cancelled right-hand side and + proves the complete equality with \<^verbatim>\Goal.prove\. +\<^enum> It returns the resulting theorem to the simplifier. A nonmatching or + malformed term returns \<^verbatim>\NONE\; interrupts and registry + ambiguity are re-raised. + +The operation/operation command follows the same registry and certificate +path, but returns a derived fact without installing it in the ambient +simpset. This is the implementation of +\<^verbatim>\locality_autocommutativity\. +\ + +subsection\How the core routines stay fast\ + +text\ +The performance strategy is to make the common lookup path narrow and to +avoid persistent pairwise state. + +\<^enum> Registration is linear in the number of entries. The authoritative + table stores one entry per registration, while secondary indexes store + structural keys and reuse Isabelle's \<^verbatim>\Symtab\, + \<^verbatim>\Typtab\, \<^verbatim>\Inttab\, and \<^verbatim>\Net\ + structures. Lookup probes the relevant record, name, family, depth, arity, + slot, and type path instead of scanning all entries. +\<^enum> Ranking is performed on index results before certificate payloads are + loaded. This makes broad fallback registrations cheap when a more specific + registration wins. +\<^enum> The planner works on the encountered telescope only. Adjacent swap + theorems and cancellation theorems are memoized in invocation-local tables + keyed by the exact typed operational patterns. They disappear when the + callback returns; no theorem cache is retained in global or proof-context + state. +\<^enum> Conversion work is bounded. Canonicalization limits exhaustive + variable-renaming search, telescope traversal is restricted to the current + term, and the proof uses small local simpsets for record equations and + generated field facts. +\<^enum> Dispatcher names encode the family identity in stable chunks, avoiding + name-size limits while keeping one generic simproc per family. Context + transport merges indexes structurally instead of rebuilding pairwise data. + +The resulting trade-off is deliberate: a complex cancellation pays for +targeted proof construction at the point of use, while declarations and +locale replay avoid quadratic theorem generation. +\ + +subsection\Diagnostics and regression instrumentation\ + +text\ +\<^verbatim>\locality_trace_level\ enables progressively verbose +diagnostic traces and \<^verbatim>\locality_timing\ reports +declaration-time proof phases. \<^verbatim>\AutoLocality_Instrumentation\ +is test support: a test starts a run, executes a controlled operation, freezes +and drains callbacks, then checks counters or resources in an immutable +snapshot. Run identifier zero is the disabled path. + +The counters expose index probes, candidate examination, planner work, +certificate construction, lifecycle replay, and fallback avoidance. They are +regression and complexity guards; they are not semantic state and not a +theorem cache. +\ + +subsection\Regression layout\ + +text\ +The executable regression theories are all under +\<^verbatim>\AutoLocality_Tests\. The B0 theories cover public behavior, +lookup, lifecycle, contexts, and import merging. The focused +\<^verbatim>\AutoLocality_Test_*\ theories cover cancellation, +shapes, locales, polymorphism, boundaries, and performance. The C1 theories +cover instrumentation and retention. Crush proofs are included in the same +session so the source tree has one test directory while the session still +declares its Crush dependency. +\ + section\Auto-Derivation of Locality Lemmas\ text\This theory provides commands for @@ -43,11 +266,7 @@ end text\Every individual example of such commutativity relations is obvious and easy to prove, but the number of relations grows up to quadratically fast in the number of operations/attributes -considered, which quickly burdensome. - -At the end of this section, the user has commands \<^verbatim>\locality_footprint\ and \<^verbatim>\locality_autoderive\ -at hand which allow them to register the footprint of operations/attributes, and have commutativity -lemmas such as the above derived automatically.\ +considered, which quickly burdensome.\ subsection\Data Structures\ @@ -55,143 +274,1880 @@ text\The following is the core datastructure that this theory maintains: A record binding an attribute/operation on a record to its footprint.\ ML\ + datatype locality_entry_kind = + Locality_Attribute + | Locality_Operation + + fun locality_entry_kind_name Locality_Attribute = "attribute" + | locality_entry_kind_name Locality_Operation = "operation" + + fun locality_entry_kind_of_string "attribute" = Locality_Attribute + | locality_entry_kind_of_string "operation" = Locality_Operation + | locality_entry_kind_of_string kind = + error ("Unknown autolocality entry kind " ^ quote kind) + + fun locality_entry_kind_ord + (Locality_Attribute, Locality_Attribute) = EQUAL + | locality_entry_kind_ord + (Locality_Attribute, Locality_Operation) = LESS + | locality_entry_kind_ord + (Locality_Operation, Locality_Attribute) = GREATER + | locality_entry_kind_ord + (Locality_Operation, Locality_Operation) = EQUAL + + type locality_canonical_env = + ((indexname * sort) * int) list * + ((indexname * typ) * int) list * int * int + + val locality_empty_canonical_env : locality_canonical_env = + ([], [], 0, 0) + + fun locality_canonical_typ (Type (name, types)) env = + let + val (types', env') = + fold_map locality_canonical_typ types env + in + (Type (name, types'), env') + end + | locality_canonical_typ (TFree free) env = + (TFree free, env) + | locality_canonical_typ + (TVar (tvar as (_, sort))) + (tvars, vars, next_tvar, next_var) = + (case AList.lookup (op =) tvars tvar of + SOME index => + (TVar (("'_locality", index), sort), + (tvars, vars, next_tvar, next_var)) + | NONE => + (TVar (("'_locality", next_tvar), sort), + ((tvar, next_tvar) :: tvars, vars, + next_tvar + 1, next_var))) + + fun locality_canonical_term (Const (name, typ)) env = + let + val (typ', env') = locality_canonical_typ typ env + in + (Const (name, typ'), env') + end + | locality_canonical_term (Free (name, typ)) env = + let + val (typ', env') = locality_canonical_typ typ env + in + (Free (name, typ'), env') + end + | locality_canonical_term + (Var (var as (_, typ))) + (env as (tvars, vars, next_tvar, next_var)) = + let + val (index, env') = + (case AList.lookup (op =) vars var of + SOME index => (index, env) + | NONE => + (next_var, + (tvars, (var, next_var) :: vars, + next_tvar, next_var + 1))) + val (typ', env'') = locality_canonical_typ typ env' + in + (Var (("_locality", index), typ'), env'') + end + | locality_canonical_term (Bound index) env = + (Bound index, env) + | locality_canonical_term (Abs (_, typ, body)) env = + let + val (typ', env') = locality_canonical_typ typ env + val (body', env'') = locality_canonical_term body env' + in + (Abs (Name.uu, typ', body'), env'') + end + | locality_canonical_term (head $ arg) env = + let + val (head', env') = locality_canonical_term head env + val (arg', env'') = locality_canonical_term arg env' + in + (head' $ arg', env'') + end + + fun locality_canonical_pattern pattern = + fst (locality_canonical_term pattern locality_empty_canonical_env) + + fun locality_remove_each [] = [] + | locality_remove_each (x :: xs) = + (x, xs) :: + map (fn (y, ys) => (y, x :: ys)) + (locality_remove_each xs) + + fun locality_permutations [] = [[]] + | locality_permutations values = + maps (fn (value, rest) => + map (cons value) (locality_permutations rest)) + (locality_remove_each values) + + fun locality_factorial n = + fold (fn i => fn result => + result * IntInf.fromInt i) (1 upto n) (1 : IntInf.int) + + fun locality_group_sorted ord values = + let + fun group [] = [] + | group (value :: values') = + let + val (same, rest) = + chop_prefix (fn value' => + ord (value, value') = EQUAL) values' + in + (value :: same) :: group rest + end + in + group (sort ord values) + end + + fun locality_group_search_count groups = + fold (fn group => fn count => + count * locality_factorial (length group)) + groups (1 : IntInf.int) + + val locality_canonical_backtrack_limit : IntInf.int = 100000 + + fun locality_check_canonical_search_bound count = + if count <= locality_canonical_backtrack_limit then () + else + error ("AutoLocality canonical variable labelling requires " + ^ IntInf.toString count ^ " alternatives; bounded limit is " + ^ IntInf.toString locality_canonical_backtrack_limit) + + fun locality_extend_canonical_tvars permutation + (tvars, vars, next_tvar, next_var) = + let + val additions = + map_index (fn (offset, tvar) => + (tvar, next_tvar + offset)) permutation + in + (additions @ tvars, vars, + next_tvar + length permutation, next_var) + end + + fun locality_extend_canonical_vars permutation + (tvars, vars, next_tvar, next_var) = + let + val additions = + map_index (fn (offset, var) => + (var, next_var + offset)) permutation + in + (tvars, additions @ vars, + next_tvar, next_var + length permutation) + end + + fun locality_extend_canonical_envs extend groups envs = + fold (fn group => fn envs' => + maps (fn env => + map (fn permutation => extend permutation env) + (locality_permutations group)) envs') + groups envs + + fun locality_canonical_env_has_tvar (tvars, _, _, _) tvar = + is_some (AList.lookup (op =) tvars tvar) + + fun locality_canonical_env_has_var (_, vars, _, _) var = + is_some (AList.lookup (op =) vars var) + + fun locality_canonical_env_size (_, _, next_tvar, next_var) = + (next_tvar, next_var) + + fun locality_canonical_typ_in_env env typ = + let + val (typ', env') = locality_canonical_typ typ env + val _ = + if locality_canonical_env_size env' = + locality_canonical_env_size env + then () + else error "Incomplete AutoLocality canonical type-variable environment" + in + typ' + end + + fun locality_remaining_canonical_envs hidden_terms env0 = + let + val remaining_tvars = + fold Term.add_tvars hidden_terms [] + |> filter_out (locality_canonical_env_has_tvar env0) + val tvar_groups = + locality_group_sorted + (Term_Ord.sort_ord o apply2 snd) remaining_tvars + val tvar_search_count = + locality_group_search_count tvar_groups + val _ = + locality_check_canonical_search_bound tvar_search_count + val tvar_envs = + locality_extend_canonical_envs + locality_extend_canonical_tvars tvar_groups [env0] + val remaining_vars = + fold Term.add_vars hidden_terms [] + |> filter_out (locality_canonical_env_has_var env0) + + fun canonical_var_groups env = + remaining_vars + |> map (fn var as (_, typ) => + (var, locality_canonical_typ_in_env env typ)) + |> locality_group_sorted + (Term_Ord.typ_ord o apply2 snd) + |> map (map fst) + + val var_plans = + map (fn env => + let + val groups = canonical_var_groups env + in + (env, groups, locality_group_search_count groups) + end) tvar_envs + val search_count = + fold (fn (_, _, count) => fn total => total + count) + var_plans (0 : IntInf.int) + val _ = + locality_check_canonical_search_bound search_count + in + maps (fn (env, groups, _) => + locality_extend_canonical_envs + locality_extend_canonical_vars groups [env]) + var_plans + end + + type locality_operational_key = { + record_name: string, + kind: locality_entry_kind, + canonical_head: term, + canonical_pattern: term, + flexible_prefix: bool list, + args: int, + idx: int + } + + fun make_locality_operational_key record_name kind pattern + flexible_prefix args idx : locality_operational_key = + let + val canonical_pattern = locality_canonical_pattern pattern + in + { record_name = record_name, + kind = kind, + canonical_head = Term.head_of canonical_pattern, + canonical_pattern = canonical_pattern, + flexible_prefix = flexible_prefix, + args = args, + idx = idx } + end + + fun locality_operational_key_ord + (key0 : locality_operational_key, + key1 : locality_operational_key) = + (fast_string_ord o apply2 #record_name + ||| locality_entry_kind_ord o apply2 #kind + ||| Term_Ord.fast_term_ord o apply2 #canonical_head + ||| Term_Ord.fast_term_ord o apply2 #canonical_pattern + ||| list_ord bool_ord o apply2 #flexible_prefix + ||| int_ord o apply2 #args + ||| int_ord o apply2 #idx) (key0, key1) + + fun locality_operational_key_eq keys = + locality_operational_key_ord keys = EQUAL + + structure LocalityOperationalKeyTable = + Table(type key = locality_operational_key + val ord = locality_operational_key_ord) + type locality_entry = { + key: locality_operational_key, const_name: string, \\The name of the attribute/operation\ - const_type: string, \\"attribute" or "operation"\ + pattern: term, \\The exact typed, possibly partially applied registration term\ footprint: string list, \\The list of record fields affecting the attribute/operation\ - args : int, \\The number of arguments to the attribute/operation\ - idx: int, \\The index of the argument that matches the target record. - This is not redundant since a term may be an attribute in - more than one way if there are repeating argument types.\ - sp : simproc option + field: bool, \\Whether this entry corresponds to a record field projection\ + core_thms: thm list, \\Linear field-update commutativity/cancellation certificates\ + disjoint_thms: thm list, \\Linear field-projection disjointness certificates\ + local_thm: thm option \\Operation-as-footprint-updates certificate\ + } + + fun make_locality_entry record_name kind const_name pattern + flexible_prefix footprint args idx field + core_thms disjoint_thms local_thm : locality_entry = + { key = make_locality_operational_key record_name kind pattern + flexible_prefix args idx, + const_name = const_name, + pattern = pattern, + footprint = footprint, + field = field, + core_thms = core_thms, + disjoint_thms = disjoint_thms, + local_thm = local_thm } + + fun locality_entry_record_name (entry : locality_entry) = + #record_name (#key entry) + + fun locality_entry_kind (entry : locality_entry) = + #kind (#key entry) + + fun locality_entry_flexible_prefix (entry : locality_entry) = + #flexible_prefix (#key entry) + + fun locality_entry_args (entry : locality_entry) = + #args (#key entry) + + fun locality_entry_idx (entry : locality_entry) = + #idx (#key entry) + + type locality_counter = + AutoLocality_Instrumentation.counter -> (unit -> IntInf.int) -> unit + + fun locality_no_count + (_ : AutoLocality_Instrumentation.counter) + (_ : unit -> IntInf.int) = () + + fun locality_make_counter ctxt add_work : locality_counter = + if AutoLocality_Instrumentation.current_run_id ctxt = + AutoLocality_Instrumentation.disabled_run_id + then locality_no_count + else + fn counter => fn make_amount => + AutoLocality_Instrumentation.record_counters ctxt (fn () => + let + val amount = make_amount () + val _ = + (case add_work of + NONE => () + | SOME add => add amount) + in [(counter, amount)] end) + + fun locality_direct_counter ctxt = + locality_make_counter ctxt NONE + + fun locality_count_one count counter = + count counter (fn () => 1) + + fun locality_count_int count counter make_amount = + count counter (fn () => IntInf.fromInt (make_amount ())) + + fun locality_count_list count counter values = + locality_count_int count counter (fn () => length values) + + fun locality_with_callback ctxt callback = + if AutoLocality_Instrumentation.current_run_id ctxt = + AutoLocality_Instrumentation.disabled_run_id + then callback locality_no_count + else + let + val work = Unsynchronized.ref (0 : IntInf.int) + fun add_work amount = work := ! work + amount + val count = locality_make_counter ctxt (SOME add_work) + in + AutoLocality_Instrumentation.with_callback ctxt + (fn () => ! work) (fn () => callback count) + end + + type locality_slot = { + pattern: term, + flexible_prefix: bool list, + kind: locality_entry_kind, + args: int, + idx: int + } + + fun locality_slot_of_entry (entry : locality_entry) : locality_slot = + { pattern = #pattern entry, + flexible_prefix = locality_entry_flexible_prefix entry, + kind = locality_entry_kind entry, + args = locality_entry_args entry, + idx = locality_entry_idx entry } + + fun morph_locality_slot phi (slot : locality_slot) : locality_slot = + { pattern = Morphism.term phi (#pattern slot), + flexible_prefix = #flexible_prefix slot, + kind = #kind slot, + args = #args slot, + idx = #idx slot } + + fun locality_slot_eq (slot0 : locality_slot, slot1 : locality_slot) = + #kind slot0 = #kind slot1 + andalso #args slot0 = #args slot1 + andalso #idx slot0 = #idx slot1 + andalso #flexible_prefix slot0 = #flexible_prefix slot1 + andalso Term.aconv + (locality_canonical_pattern (#pattern slot0), + locality_canonical_pattern (#pattern slot1)) + + fun locality_entry_slot_eq (e0 : locality_entry, e1 : locality_entry) = + locality_operational_key_eq (#key e0, #key e1) + + fun locality_pattern_flexible_prefix pattern = + snd (Term.strip_comb pattern) + |> map (fn arg => not (null (Term.add_frees arg []))) + + \\Symmetric comparison for exact same-target command replay.\ + fun locality_registration_pattern_eq _ + (pattern0, pattern1) = + Term.aconv + (locality_canonical_pattern pattern0, + locality_canonical_pattern pattern1) + + type locality_thm_fingerprint = term * term list * sort list + + type locality_entry_certificate_fingerprint = { + pattern: term, + core: locality_thm_fingerprint list, + disjoint: locality_thm_fingerprint list, + local_certificate: locality_thm_fingerprint option } - \\Type used to store pairs of attributes/operations that operate on disjoint footprints\ - type disjoint_pair = string * string + fun locality_thm_fingerprint env prop thm : + locality_thm_fingerprint = + let + val (hyps, env') = + fold_map locality_canonical_term (Thm.hyps_of thm) env + val _ = + if locality_canonical_env_size env' = + locality_canonical_env_size env + then () + else error "Incomplete AutoLocality canonical theorem environment" + val canonical_hyps = + sort Term_Ord.fast_term_ord hyps + val shyps = Thm.shyps_of thm |> sort Term_Ord.sort_ord + in + (prop, canonical_hyps, shyps) + end + + fun locality_thm_fingerprint_ord + (fingerprint0 : locality_thm_fingerprint, + fingerprint1 : locality_thm_fingerprint) = + (Term_Ord.fast_term_ord o apply2 #1 + ||| list_ord Term_Ord.fast_term_ord o apply2 #2 + ||| list_ord Term_Ord.sort_ord o apply2 #3) + (fingerprint0, fingerprint1) + + fun locality_entry_certificate_fingerprint_ord + (fingerprint0 : locality_entry_certificate_fingerprint, + fingerprint1 : locality_entry_certificate_fingerprint) = + (Term_Ord.fast_term_ord o apply2 #pattern + ||| list_ord locality_thm_fingerprint_ord o apply2 #core + ||| list_ord locality_thm_fingerprint_ord o apply2 #disjoint + ||| option_ord locality_thm_fingerprint_ord + o apply2 #local_certificate) + (fingerprint0, fingerprint1) + + \\The pattern and all role-ordered certificate propositions form the ordered roots + of one occurrence graph. First occurrence fixes labels there. Variables that occur only + in unordered hidden hypotheses are individualized over name-independent sort/type + colour classes; bounded exhaustive backtracking chooses the least complete bundle.\ + fun locality_entry_certificate_fingerprint + (entry : locality_entry) : + locality_entry_certificate_fingerprint = + let + val core_thms = #core_thms entry + val disjoint_thms = #disjoint_thms entry + val local_thms = the_list (#local_thm entry) + val thms = core_thms @ disjoint_thms @ local_thms + val ordered_roots = + #pattern entry :: map Thm.full_prop_of thms + val (canonical_roots, ordered_env) = + fold_map locality_canonical_term ordered_roots + locality_empty_canonical_env + val (canonical_pattern, canonical_props) = + (case canonical_roots of + pattern :: props => (pattern, props) + | [] => error "Missing AutoLocality operational-pattern root") + val hidden_terms = maps Thm.hyps_of thms + val complete_envs = + locality_remaining_canonical_envs hidden_terms ordered_env + + fun fingerprint_for_env env = + let + val thm_fingerprints = + map2 (fn prop => fn thm => + locality_thm_fingerprint env prop thm) + canonical_props thms + val (core, thm_fingerprints') = + chop (length core_thms) thm_fingerprints + val (disjoint, local_fingerprints) = + chop (length disjoint_thms) thm_fingerprints' + val local_certificate = + (case (#local_thm entry, local_fingerprints) of + (NONE, []) => NONE + | (SOME _, [fingerprint]) => SOME fingerprint + | _ => + error "Malformed AutoLocality certificate fingerprint") + in + { pattern = canonical_pattern, + core = core, + disjoint = disjoint, + local_certificate = local_certificate } + end + + fun choose env NONE = + SOME (fingerprint_for_env env) + | choose env (SOME best) = + let + val candidate = fingerprint_for_env env + in + SOME + (case locality_entry_certificate_fingerprint_ord + (candidate, best) of + LESS => candidate + | _ => best) + end + in + fold choose complete_envs NONE |> the + end - \\Global data for tracking footprints of operations\ + fun locality_entry_conflict (entry : locality_entry) detail = + error ("Conflicting autolocality registrations for " + ^ #const_name entry ^ " on " ^ locality_entry_record_name entry + ^ ": " ^ detail) + + fun locality_entry_merge_conflict + (entry0 : locality_entry, entry1 : locality_entry) detail = + let + val names = + sort_distinct fast_string_ord [#const_name entry0, #const_name entry1] + val records = + sort_distinct fast_string_ord + [locality_entry_record_name entry0, + locality_entry_record_name entry1] + in + error ("Conflicting autolocality registrations for " + ^ commas_quote names ^ " on " ^ commas_quote records + ^ ": " ^ detail) + end + + fun canonical_locality_entry_representative + (entry0 : locality_entry, entry1 : locality_entry) = + (case Term_Ord.fast_term_ord + (#pattern entry0, #pattern entry1) of + GREATER => entry1 + | _ => entry0) + + fun canonical_locality_footprint (footprint0, footprint1) = + (case list_ord fast_string_ord (footprint0, footprint1) of + GREATER => footprint1 + | _ => footprint0) + + fun merge_locality_entry + (e0 : locality_entry, e1 : locality_entry) : locality_entry = + if not (locality_entry_slot_eq (e0, e1)) then + locality_entry_merge_conflict (e0, e1) "operational keys differ" + else if #const_name e0 <> #const_name e1 then + locality_entry_merge_conflict (e0, e1) "constant identities differ" + else if not (eq_set (op =) (#footprint e0, #footprint e1)) then + locality_entry_merge_conflict (e0, e1) "footprints differ" + else if #field e0 <> #field e1 then + locality_entry_merge_conflict (e0, e1) "field metadata differs" + else if length (#core_thms e0) <> length (#core_thms e1) then + locality_entry_merge_conflict (e0, e1) + "core certificate completeness differs" + else if length (#disjoint_thms e0) <> length (#disjoint_thms e1) then + locality_entry_merge_conflict (e0, e1) + "disjoint certificate completeness differs" + else if Option.isSome (#local_thm e0) <> Option.isSome (#local_thm e1) then + locality_entry_merge_conflict (e0, e1) + "local-action certificate completeness differs" + else if locality_entry_certificate_fingerprint_ord + (locality_entry_certificate_fingerprint e0, + locality_entry_certificate_fingerprint e1) <> EQUAL + then + locality_entry_merge_conflict (e0, e1) + ("certificate propositions, hidden hypotheses, sort hypotheses, " + ^ "or pattern-variable sharing differ") + else + let + val representative = + canonical_locality_entry_representative (e0, e1) + in + { key = #key representative, + const_name = #const_name representative, + pattern = #pattern representative, + footprint = + canonical_locality_footprint (#footprint e0, #footprint e1), + field = #field representative, + core_thms = #core_thms representative, + disjoint_thms = #disjoint_thms representative, + local_thm = #local_thm representative } + end + + fun insert_locality_entry (entry : locality_entry) = + LocalityOperationalKeyTable.map_default + (#key entry, entry) + (fn entry' => merge_locality_entry (entry', entry)) + + fun locality_entry_table_of entries = + LocalityOperationalKeyTable.build + (fold insert_locality_entry entries) + + fun merge_locality_entry_tables tables = + LocalityOperationalKeyTable.join + (K merge_locality_entry) tables + + \\Compatibility list views remain deterministic structural-key order, not historical + insertion order. Stage-2B2 owns any later ordinal compatibility index.\ + fun locality_entries_of_table table = + LocalityOperationalKeyTable.dest table |> map #2 + + fun merge_locality_entry_lists (entries0, entries1) = + merge_locality_entry_tables + (locality_entry_table_of entries0, locality_entry_table_of entries1) + |> locality_entries_of_table + + \\Global data for tracking footprints of operations. One structural operational-key + table owns the semantic entries; record-indexed list APIs below are derived compatibility + views. Pairwise commutativity/cancellation lemmas are no longer pre-generated, so no + disjointness bookkeeping is needed; cancellations are handled on-the-fly by the + \<^verbatim>\locality_cancel\ simprocs.\ structure RecordLocalityData = Generic_Data ( - type T = (locality_entry list Symtab.table * \\record-indexed table of footprint data\ - disjoint_pair list Symtab.table); \\record-indexed table of names of disjoint attributes/operations\ - val empty = (Symtab.empty, Symtab.empty); - fun merge ((tA0, tA1), (tB0, tB1)) = - (Symtab.merge_list (fn ({const_name=t0, ...},{const_name=t1,...}) => t0 = t1) (tA0, tB0), - Symtab.merge_list (fn (t0,t1) => t0 = t1) (tA1, tB1)); + type T = locality_entry LocalityOperationalKeyTable.table; + val empty = LocalityOperationalKeyTable.empty; + val merge = merge_locality_entry_tables; ); - \\Register the footprint for a new attribute/operation.\ - fun add_record_locality_entry_generic ctxt (rec_name : string) (ty : string) (f : string) - (footprint : string list) (args : int) (idx : int) (sp : simproc option) = + type locality_key_set = unit LocalityOperationalKeyTable.table + + val empty_locality_key_set : locality_key_set = + LocalityOperationalKeyTable.empty + + fun insert_locality_key key = + LocalityOperationalKeyTable.map_default (key, ()) (K ()) + + fun merge_locality_key_sets key_sets = + LocalityOperationalKeyTable.join (K (fn _ => ())) key_sets + + fun locality_name_index_names name = + distinct (op =) [name, Long_Name.base_name name] + + type locality_replay_key = { + record_name: string, + canonical_pattern: term, + idx: int + } + + fun locality_replay_key_ord + (key0 : locality_replay_key, key1 : locality_replay_key) = + (fast_string_ord o apply2 #record_name + ||| Term_Ord.fast_term_ord o apply2 #canonical_pattern + ||| int_ord o apply2 #idx) (key0, key1) + + structure LocalityReplayKeyTable = + Table(type key = locality_replay_key + val ord = locality_replay_key_ord) + + fun locality_replay_key record_name pattern idx : locality_replay_key = + { record_name = record_name, + canonical_pattern = locality_canonical_pattern pattern, + idx = idx } + + datatype locality_family_head = + Locality_Family_Const of string + | Locality_Family_Term of term + + fun locality_family_head_ord + (Locality_Family_Const name0, Locality_Family_Const name1) = + fast_string_ord (name0, name1) + | locality_family_head_ord + (Locality_Family_Const _, Locality_Family_Term _) = LESS + | locality_family_head_ord + (Locality_Family_Term _, Locality_Family_Const _) = GREATER + | locality_family_head_ord + (Locality_Family_Term head0, Locality_Family_Term head1) = + Term_Ord.fast_term_ord (head0, head1) + + fun locality_family_head (Const (name, _)) = + Locality_Family_Const name + | locality_family_head head = + Locality_Family_Term (locality_canonical_pattern head) + + type locality_family_key = { + record_name: string, + kind: locality_entry_kind, + head: locality_family_head + } + + fun locality_family_key_ord + (key0 : locality_family_key, key1 : locality_family_key) = + (fast_string_ord o apply2 #record_name + ||| locality_entry_kind_ord o apply2 #kind + ||| locality_family_head_ord o apply2 #head) (key0, key1) + + structure LocalityFamilyKeyTable = + Table(type key = locality_family_key + val ord = locality_family_key_ord) + + fun locality_constant_head_name (Const (name, _)) = SOME name + | locality_constant_head_name _ = NONE + + fun locality_rigid_head_name head = + (case locality_constant_head_name head of + SOME name => name + | NONE => + error ("AutoLocality registration has non-constant rigid head " + ^ ML_Syntax.print_term head)) + + fun locality_family_key_of_operational_key + (key : locality_operational_key) : locality_family_key = + { record_name = #record_name key, + kind = #kind key, + head = locality_family_head (#canonical_head key) } + + type locality_dispatch_key = { + head_name: string, + arity: int + } + + fun locality_dispatch_key_ord + (key0 : locality_dispatch_key, key1 : locality_dispatch_key) = + (fast_string_ord o apply2 #head_name + ||| int_ord o apply2 #arity) (key0, key1) + + fun locality_dispatch_key_eq keys = + locality_dispatch_key_ord keys = EQUAL + + structure LocalityDispatchKeyTable = + Table(type key = locality_dispatch_key + val ord = locality_dispatch_key_ord) + + \\The physical family arity is the complete arrow spine of the rigid constant's + declared type, never the number of arguments exposed by one registration. Thus partial + registrations and constants with explicitly function-valued results share the same trigger. + A semantic registration may consume only a prefix of that declared spine. Expanded + abbreviations have structural lambda heads and therefore remain semantic registrations + without a named physical dispatcher.\ + fun locality_dispatch_key_of_operational_key_opt thy + (key : locality_operational_key) : locality_dispatch_key option = + (case locality_constant_head_name (#canonical_head key) of + NONE => NONE + | SOME head_name => + let + val declared_arity = + Sign.the_const_type thy head_name + |> Term.binder_types + |> length + val registered_arity = + length (snd (Term.strip_comb (#canonical_pattern key))) + + #args key + val _ = + if registered_arity <= declared_arity then () + else + error ("AutoLocality registration consumes " + ^ Int.toString registered_arity ^ " arguments of " + ^ quote head_name ^ " with declared spine arity " + ^ Int.toString declared_arity) + in + SOME + { head_name = head_name, + arity = declared_arity } + end) + + fun locality_dispatch_key_of_operational_key thy key = + (case locality_dispatch_key_of_operational_key_opt thy key of + SOME dispatch_key => dispatch_key + | NONE => + error ("AutoLocality registration has no constant dispatcher head " + ^ ML_Syntax.print_term (#canonical_head key))) + + fun locality_dispatch_key_of_entry ctxt (entry : locality_entry) = + locality_dispatch_key_of_operational_key + (Proof_Context.theory_of ctxt) (#key entry) + + fun locality_dispatch_key_of_entry_opt ctxt (entry : locality_entry) = + locality_dispatch_key_of_operational_key_opt + (Proof_Context.theory_of ctxt) (#key entry) + + fun locality_index_varify_atyps tfrees base = + let + val instantiations = + tfrees |> map_index (fn (i, (name, sort)) => + ((name, sort), TVar ((name, base + i), sort))) + in + fn TFree key => + AList.lookup (op =) instantiations key + |> the_default (TFree key) + | typ => typ + end + + fun locality_index_varify_types term = + let + val tfrees = Term.add_tfrees term [] + val base = Term.maxidx_of_term term + 1 + in + Term.map_types + (Term.map_atyps (locality_index_varify_atyps tfrees base)) term + end + + fun locality_match_pattern pattern flexible_prefix = + let + val pattern_scheme = + locality_index_varify_types pattern + val (head, args) = Term.strip_comb pattern_scheme + val _ = + if length flexible_prefix = length args then () + else error "Malformed autolocality flexible-prefix metadata" + val base = Term.maxidx_of_term pattern_scheme + 1 + val args' = + (args ~~ flexible_prefix) |> map_index (fn (i, (arg, flexible)) => + if flexible + then Var (("locality_prefix", base + i), Term.type_of arg) + else arg) + in + Term.list_comb (head, args') + end + + fun locality_index_match_pattern + (key : locality_operational_key) = + locality_match_pattern + (#canonical_pattern key) (#flexible_prefix key) + + fun locality_type_is_monomorphic typ = + null (Term.add_tvarsT typ []) + andalso null (Term.add_tfreesT typ []) + + fun locality_polymorphic_index_pattern typ pattern = + Const ("AutoLocality.index", dummyT) + $ Net.encode_type typ $ pattern + + type locality_key_net = locality_operational_key Net.net + + val empty_locality_key_net : locality_key_net = Net.empty + + fun locality_index_normalize term = + Envir.beta_eta_contract term + + fun insert_locality_key_net pattern key = + Net.insert_term_safe locality_operational_key_eq + (locality_index_normalize pattern, key) + + fun merge_locality_key_nets nets = + Net.merge locality_operational_key_eq nets + + type locality_path_index = { + exact_rigid: locality_key_net Typtab.table, + exact_flexible: locality_key_net Typtab.table, + polymorphic_rigid: locality_key_net, + polymorphic_flexible: locality_key_net + } + + val empty_locality_path_index : locality_path_index = + { exact_rigid = Typtab.empty, + exact_flexible = Typtab.empty, + polymorphic_rigid = empty_locality_key_net, + polymorphic_flexible = empty_locality_key_net } + + fun insert_locality_path_key + (key : locality_operational_key) + (path : locality_path_index) : locality_path_index = + let + val pattern = + locality_index_match_pattern key + |> locality_index_normalize + val head_type = Term.type_of (Term.head_of pattern) + val flexible = exists I (#flexible_prefix key) + fun insert_exact table = + Typtab.map_default + (head_type, empty_locality_key_net) + (insert_locality_key_net pattern key) table + fun insert_polymorphic net = + insert_locality_key_net + (locality_polymorphic_index_pattern head_type pattern) key net + in + if locality_type_is_monomorphic head_type then + if flexible then + { exact_rigid = #exact_rigid path, + exact_flexible = insert_exact (#exact_flexible path), + polymorphic_rigid = #polymorphic_rigid path, + polymorphic_flexible = #polymorphic_flexible path } + else + { exact_rigid = insert_exact (#exact_rigid path), + exact_flexible = #exact_flexible path, + polymorphic_rigid = #polymorphic_rigid path, + polymorphic_flexible = #polymorphic_flexible path } + else if flexible then + { exact_rigid = #exact_rigid path, + exact_flexible = #exact_flexible path, + polymorphic_rigid = #polymorphic_rigid path, + polymorphic_flexible = + insert_polymorphic (#polymorphic_flexible path) } + else + { exact_rigid = #exact_rigid path, + exact_flexible = #exact_flexible path, + polymorphic_rigid = + insert_polymorphic (#polymorphic_rigid path), + polymorphic_flexible = #polymorphic_flexible path } + end + + fun merge_locality_path_indexes + (path0 : locality_path_index, + path1 : locality_path_index) : locality_path_index = + { exact_rigid = + Typtab.join (K merge_locality_key_nets) + (#exact_rigid path0, #exact_rigid path1), + exact_flexible = + Typtab.join (K merge_locality_key_nets) + (#exact_flexible path0, #exact_flexible path1), + polymorphic_rigid = + merge_locality_key_nets + (#polymorphic_rigid path0, #polymorphic_rigid path1), + polymorphic_flexible = + merge_locality_key_nets + (#polymorphic_flexible path0, #polymorphic_flexible path1) } + + type locality_slot_paths = locality_path_index Inttab.table + type locality_arity_paths = locality_slot_paths Inttab.table + type locality_depth_paths = locality_arity_paths Inttab.table + type locality_family_paths = + locality_depth_paths LocalityFamilyKeyTable.table + + fun insert_locality_depth_path + (entry : locality_entry) + (depths : locality_depth_paths) : locality_depth_paths = + let + val key = #key entry + val depth = length (snd (Term.strip_comb (#canonical_pattern key))) + in + depths + |> Inttab.map_default (depth, Inttab.empty) + (Inttab.map_default (#args key, Inttab.empty) + (Inttab.map_default + (#idx key, empty_locality_path_index) + (insert_locality_path_key key))) + end + + fun merge_locality_slot_paths paths = + Inttab.join (K merge_locality_path_indexes) paths + + fun merge_locality_arity_paths paths = + Inttab.join (K merge_locality_slot_paths) paths + + fun merge_locality_depth_paths paths = + Inttab.join (K merge_locality_arity_paths) paths + + fun merge_locality_family_paths paths = + LocalityFamilyKeyTable.join (K merge_locality_depth_paths) paths + + fun insert_locality_family_path + (entry : locality_entry) + (families : locality_family_paths) : locality_family_paths = + let + val family = + locality_family_key_of_operational_key (#key entry) + in + LocalityFamilyKeyTable.map_default + (family, Inttab.empty) + (insert_locality_depth_path entry) families + end + + type locality_dispatch_paths = + locality_depth_paths LocalityDispatchKeyTable.table + + fun insert_locality_dispatch_path dispatch_key entry = + LocalityDispatchKeyTable.map_default + (dispatch_key, Inttab.empty) + (insert_locality_depth_path entry) + + fun merge_locality_dispatch_paths paths = + LocalityDispatchKeyTable.join + (K merge_locality_depth_paths) paths + + type locality_secondary_index = { + records: locality_key_set Symtab.table, + names: locality_key_set Symtab.table Symtab.table, + replay_slots: locality_key_set LocalityReplayKeyTable.table, + families: locality_family_paths, + dispatch: locality_dispatch_paths + } + + val empty_locality_secondary_index : locality_secondary_index = + { records = Symtab.empty, + names = Symtab.empty, + replay_slots = LocalityReplayKeyTable.empty, + families = LocalityFamilyKeyTable.empty, + dispatch = LocalityDispatchKeyTable.empty } + + fun insert_locality_secondary_key_with_dispatch dispatch_key + (entry : locality_entry) + (index : locality_secondary_index) : locality_secondary_index = + let + val key = #key entry + val record_name = locality_entry_record_name entry + val indexed_names = + locality_name_index_names (#const_name entry) + val replay_key = + locality_replay_key record_name (#pattern entry) + (locality_entry_idx entry) + in + { records = + #records index + |> Symtab.map_default + (record_name, empty_locality_key_set) + (insert_locality_key key), + names = + #names index + |> Symtab.map_default (record_name, Symtab.empty) + (fn names => + fold (fn name => + Symtab.map_default + (name, empty_locality_key_set) + (insert_locality_key key)) + indexed_names names), + replay_slots = + #replay_slots index + |> LocalityReplayKeyTable.map_default + (replay_key, empty_locality_key_set) + (insert_locality_key key), + families = + insert_locality_family_path entry (#families index), + dispatch = + (case dispatch_key of + NONE => #dispatch index + | SOME key => + if locality_entry_kind entry = Locality_Attribute + then + insert_locality_dispatch_path key entry + (#dispatch index) + else + error "Malformed AutoLocality dispatch-index insertion") } + end + + fun insert_locality_secondary_key entry = + insert_locality_secondary_key_with_dispatch NONE entry + + fun merge_locality_secondary_indexes + (index0 : locality_secondary_index, + index1 : locality_secondary_index) : locality_secondary_index = + { records = + Symtab.join (K merge_locality_key_sets) + (#records index0, #records index1), + names = + Symtab.join + (K (Symtab.join (K merge_locality_key_sets))) + (#names index0, #names index1), + replay_slots = + LocalityReplayKeyTable.join + (K merge_locality_key_sets) + (#replay_slots index0, #replay_slots index1), + families = + merge_locality_family_paths + (#families index0, #families index1), + dispatch = + merge_locality_dispatch_paths + (#dispatch index0, #dispatch index1) } + + \\All secondary tables contain structural operational keys only. The authoritative + table above remains the sole owner of entries and theorem certificates.\ + structure LocalitySecondaryIndex = Generic_Data + ( + type T = locality_secondary_index; + val empty = empty_locality_secondary_index; + val merge = merge_locality_secondary_indexes; + ); + + fun locality_index_probe count lookup = + (locality_count_one count + AutoLocality_Instrumentation.Lookup_Index_Probes; + lookup ()) + + fun locality_keys_for_names_with count context record_name names = + let + val indexed_names = + locality_index_probe count (fn () => + Symtab.lookup + (#names (LocalitySecondaryIndex.get context)) record_name) + fun add_name _ keys NONE = keys + | add_name name keys (SOME names_for_record) = + (case locality_index_probe count (fn () => + Symtab.lookup names_for_record name) of + NONE => keys + | SOME keys' => merge_locality_key_sets (keys, keys')) + in + fold (fn name => fn keys => + add_name name keys indexed_names) + (distinct (op =) names) empty_locality_key_set + end + + fun locality_key_set_of_list keys = + fold insert_locality_key keys empty_locality_key_set + + fun capture_noninterrupt f = + (case Exn.capture f () of + Exn.Res result => SOME result + | Exn.Exn exn => + if Exn.is_interrupt exn then Exn.reraise exn else NONE) + + fun locality_terms_provably_equal_with count ctxt (lhs, rhs) = + let + val _ = locality_count_one count + AutoLocality_Instrumentation.Lookup_Equality_Attempts + in + Term.aconv (lhs, rhs) orelse + Option.isSome (capture_noninterrupt (fn () => + Goal.prove ctxt [] [] (Logic.mk_equals (lhs, rhs)) + (fn {context, ...} => + asm_full_simp_tac (context addsimps @{thms fun_eq_iff}) 1))) + end + + fun locality_terms_provably_equal ctxt pair = + locality_terms_provably_equal_with locality_no_count ctxt pair + + fun locality_pattern_flexible_pairs ctxt actual pattern flexible_prefix = + let + val thy = Proof_Context.theory_of ctxt + val match_pattern = + locality_match_pattern pattern flexible_prefix + val env = + Pattern.match thy (match_pattern, actual) + (Vartab.empty, Vartab.empty) + val (_, stored_args) = + pattern |> locality_index_varify_types |> Term.strip_comb + val (_, actual_args) = Term.strip_comb actual + in + (stored_args ~~ actual_args ~~ flexible_prefix) + |> map_filter (fn ((stored, actual), flexible) => + if flexible + then SOME (Envir.subst_term env stored, actual) + else NONE) + end + + fun locality_pattern_matches_prefix_with count ctxt + actual pattern flexible_prefix = + let + val _ = locality_count_one count + AutoLocality_Instrumentation.Lookup_Prefix_Alternatives + in + Option.isSome (capture_noninterrupt (fn () => + let + val flexible_pairs = + locality_pattern_flexible_pairs + ctxt actual pattern flexible_prefix + val _ = + if List.all (locality_terms_provably_equal_with count ctxt) + flexible_pairs + then () + else raise Pattern.MATCH + in () end)) + end + + fun locality_key_matches_prefix_with count ctxt actual + (key : locality_operational_key) = + locality_pattern_matches_prefix_with count ctxt actual + (#canonical_pattern key) (#flexible_prefix key) + + datatype locality_path_class = + Locality_Exact_Rigid_Path + | Locality_Exact_Flexible_Path + | Locality_Polymorphic_Rigid_Path + | Locality_Polymorphic_Flexible_Path + + type locality_query_rank = { + exact_type: bool, + rigid_prefix: bool, + prefix_length: int + } + + fun locality_query_rank_ord + (rank0 : locality_query_rank, + rank1 : locality_query_rank) = + (bool_ord o apply2 #exact_type + ||| bool_ord o apply2 #rigid_prefix + ||| int_ord o apply2 #prefix_length) (rank0, rank1) + + fun locality_path_class_rank prefix_length path_class + : locality_query_rank = + case path_class of + Locality_Exact_Rigid_Path => + { exact_type = true, + rigid_prefix = true, + prefix_length = prefix_length } + | Locality_Exact_Flexible_Path => + { exact_type = true, + rigid_prefix = false, + prefix_length = prefix_length } + | Locality_Polymorphic_Rigid_Path => + { exact_type = false, + rigid_prefix = true, + prefix_length = prefix_length } + | Locality_Polymorphic_Flexible_Path => + { exact_type = false, + rigid_prefix = false, + prefix_length = prefix_length } + + val locality_path_classes_by_rank = + [Locality_Exact_Rigid_Path, + Locality_Exact_Flexible_Path, + Locality_Polymorphic_Rigid_Path, + Locality_Polymorphic_Flexible_Path] + + fun locality_path_class_keys_with count actual path_class + (path : locality_path_index) = + let + val normalized_actual = + locality_index_normalize actual + val head_type = + Term.type_of (Term.head_of normalized_actual) + fun net_keys net query = + locality_index_probe count (fn () => + Net.match_term net (locality_index_normalize query) + |> locality_key_set_of_list) + fun exact_keys exact = + (case locality_index_probe count (fn () => + Typtab.lookup exact head_type) of + NONE => empty_locality_key_set + | SOME net => net_keys net normalized_actual) + val polymorphic_actual = + locality_polymorphic_index_pattern + head_type normalized_actual + in + case path_class of + Locality_Exact_Rigid_Path => + exact_keys (#exact_rigid path) + | Locality_Exact_Flexible_Path => + exact_keys (#exact_flexible path) + | Locality_Polymorphic_Rigid_Path => + net_keys (#polymorphic_rigid path) polymorphic_actual + | Locality_Polymorphic_Flexible_Path => + net_keys (#polymorphic_flexible path) polymorphic_actual + end + + fun locality_filter_key_set predicate keys = + LocalityOperationalKeyTable.fold + (fn (key, ()) => fn result => + if predicate key then insert_locality_key key result + else result) + keys empty_locality_key_set + + fun locality_key_is_exact_pattern actual + (key : locality_operational_key) = + Term.aconv + (locality_canonical_pattern actual, #canonical_pattern key) + + type locality_ranked_key_query = { + rank: locality_query_rank, + actual: term, + retrieve: unit -> locality_key_set + } + + fun locality_equality_valid_keys_with count ctxt actual keys = + let + val valid = + locality_filter_key_set + (locality_key_matches_prefix_with count ctxt actual) keys + val exact = + locality_filter_key_set + (locality_key_is_exact_pattern actual) valid + in + if LocalityOperationalKeyTable.is_empty exact + then valid + else exact + end + + fun locality_maximal_rank_keys_with count ctxt queries = + let + fun consider (query : locality_ranked_key_query) + (previous_rank, selected) = + let + val rank = #rank query + val _ = + (case previous_rank of + NONE => () + | SOME previous => + if locality_query_rank_ord (previous, rank) = LESS + then error "Malformed ascending autolocality query rank" + else ()) + val selected' = + (case selected of + SOME keys => SOME keys + | NONE => + let + val keys = + #retrieve query () + |> locality_equality_valid_keys_with + count ctxt (#actual query) + in + if LocalityOperationalKeyTable.is_empty keys + then NONE + else SOME keys + end) + in + (SOME rank, selected') + end + val (_, selected) = fold consider queries (NONE, NONE) + in + the_default empty_locality_key_set selected + end + + fun locality_dispatch_ranked_key_queries_with count ctxt + (dispatch_key : locality_dispatch_key) actual = let - val entry = {const_name = f, const_type=ty, footprint=footprint, args=args, idx=idx, sp=sp} - val g = Symtab.map_default (rec_name, []) (fn ls => ls @ [entry]) - val _ = Pretty.text "Registering footprint" @ [Pretty.brk 1, Pretty.list "[" "]" (List.map Pretty.str footprint), Pretty.brk 1] - @ Pretty.text "for constant" @ [Pretty.brk 1, Pretty.str f, Pretty.brk 1] - @ Pretty.text "for record" @ [Pretty.brk 1, Pretty.str rec_name] |> Pretty.block - |> locality_pretty_trace ctxt 1 + val context = Context.Proof ctxt + val indexed_paths = + locality_index_probe count (fn () => + LocalityDispatchKeyTable.lookup + (#dispatch (LocalitySecondaryIndex.get context)) dispatch_key) + val (actual_head, actual_args) = Term.strip_comb actual + val argument_count = length actual_args + val shape_matches = + (case actual_head of + Const (head_name, _) => + head_name = #head_name dispatch_key + andalso argument_count = #arity dispatch_key + | _ => false) + fun int_range first last = + if first > last then [] else first upto last + fun int_range_down first last = + if first < last then [] + else first :: int_range_down (first - 1) last + fun add_slot path_class actual slots slot keys = + (case locality_index_probe count (fn () => + Inttab.lookup slots slot) of + NONE => keys + | SOME path => + merge_locality_key_sets + (keys, + locality_path_class_keys_with + count actual path_class path)) + fun add_arity path_class actual arities arity keys = + (case locality_index_probe count (fn () => + Inttab.lookup arities arity) of + NONE => keys + | SOME slots => + fold (add_slot path_class actual slots) + (int_range 0 (arity - 1)) keys) + fun retrieve depths path_class depth actual () = + (case locality_index_probe count (fn () => + Inttab.lookup depths depth) of + NONE => empty_locality_key_set + | SOME arities => + fold (add_arity path_class actual arities) + (int_range 0 (argument_count - depth)) + empty_locality_key_set) + fun ranked_query depths path_class depth = + let + val actual_prefix = + Term.list_comb + (actual_head, List.take (actual_args, depth)) + in + { rank = locality_path_class_rank depth path_class, + actual = actual_prefix, + retrieve = + retrieve depths path_class depth actual_prefix } + end + fun ranked_queries depths path_class = + map (ranked_query depths path_class) + (int_range_down argument_count 0) in - RecordLocalityData.map (g |> apfst) + if not shape_matches then [] + else + (case indexed_paths of + NONE => [] + | SOME depths => + maps (ranked_queries depths) + locality_path_classes_by_rank) end - fun order_pair (a,b) = if a < b then (a,b) else (b,a) + fun locality_family_paths_with count context record_name kind head = + locality_index_probe count (fn () => + let + val family : locality_family_key = + { record_name = record_name, + kind = kind, + head = locality_family_head head } + in + LocalityFamilyKeyTable.lookup + (#families (LocalitySecondaryIndex.get context)) family + end) + + fun locality_int_range first last = + if first > last then [] else first upto last + + fun locality_int_range_down first last = + if first < last then [] + else first :: locality_int_range_down (first - 1) last + + fun locality_application_keys_with count ctxt record_name kind + head args = + let + val argument_count = length args + fun add_slot path_class actual slots slot keys = + (case locality_index_probe count (fn () => + Inttab.lookup slots slot) of + NONE => keys + | SOME path => + merge_locality_key_sets + (keys, + locality_path_class_keys_with + count actual path_class path)) + fun add_arity path_class actual arities arity keys = + (case locality_index_probe count (fn () => + Inttab.lookup arities arity) of + NONE => keys + | SOME slots => + fold (add_slot path_class actual slots) + (locality_int_range 0 (arity - 1)) keys) + fun retrieve depths path_class depth actual () = + (case locality_index_probe count (fn () => + Inttab.lookup depths depth) of + NONE => empty_locality_key_set + | SOME arities => + fold (add_arity path_class actual arities) + (locality_int_range 0 (argument_count - depth)) + empty_locality_key_set) + fun ranked_query depths path_class depth = + let + val actual = + Term.list_comb (head, List.take (args, depth)) + in + { rank = locality_path_class_rank depth path_class, + actual = actual, + retrieve = retrieve depths path_class depth actual } + end + fun ranked_queries depths path_class = + map (ranked_query depths path_class) + (locality_int_range_down argument_count 0) + in + case locality_family_paths_with + count (Context.Proof ctxt) record_name kind head of + NONE => empty_locality_key_set + | SOME depths => + maps (ranked_queries depths) locality_path_classes_by_rank + |> locality_maximal_rank_keys_with count ctxt + end - \\Generic context transformation for registerins a disoint pair of attributes/operations on a record.\ - fun add_record_disjoint_pair_generic (rec_name : string) (cA : string) (cB : string) - : Context.generic -> Context.generic = + fun locality_pattern_keys_with count ctxt record_name kind pattern = let - val (cA, cB) = order_pair (cA, cB) - val f = Symtab.map_default (rec_name, []) (fn ls => ls @ [(cA, cB)]) + val (head, prefix_args) = Term.strip_comb pattern + val depth = length prefix_args + val max_arity = + length (Term.binder_types (Term.type_of pattern)) + fun add_slot path_class slots slot keys = + (case locality_index_probe count (fn () => + Inttab.lookup slots slot) of + NONE => keys + | SOME path => + merge_locality_key_sets + (keys, + locality_path_class_keys_with + count pattern path_class path)) + fun add_arity path_class arities arity keys = + (case locality_index_probe count (fn () => + Inttab.lookup arities arity) of + NONE => keys + | SOME slots => + fold (add_slot path_class slots) + (locality_int_range 0 (arity - 1)) keys) + fun retrieve arities path_class () = + fold (add_arity path_class arities) + (locality_int_range 0 max_arity) + empty_locality_key_set + fun ranked_query arities path_class = + { rank = locality_path_class_rank depth path_class, + actual = pattern, + retrieve = retrieve arities path_class } in - RecordLocalityData.map (f |> apsnd) + case locality_family_paths_with + count (Context.Proof ctxt) record_name kind head of + NONE => empty_locality_key_set + | SOME depths => + (case locality_index_probe count (fn () => + Inttab.lookup depths depth) of + NONE => empty_locality_key_set + | SOME arities => + map (ranked_query arities) + locality_path_classes_by_rank + |> locality_maximal_rank_keys_with count ctxt) end - \\Theory transformation adding a new footprint entry\ - fun add_record_locality_entry ctxt (rec_name : string) (ty : string) (f : string) - (footprint : string list) (args : int) (idx : int) (sp : simproc option) : local_theory -> local_theory = - Local_Theory.declaration {pervasive=false, syntax=false, pos=Position.none} - (K (add_record_locality_entry_generic ctxt rec_name ty f footprint args idx sp)) + fun locality_pattern_at_idx_keys_with count ctxt record_name kind + pattern absolute_idx = + let + val (head, prefix_args) = Term.strip_comb pattern + val depth = length prefix_args + val relative_idx = absolute_idx - depth + val max_arity = + length (Term.binder_types (Term.type_of pattern)) + fun add_arity path_class arities arity keys = + (case locality_index_probe count (fn () => + Inttab.lookup arities arity) of + NONE => keys + | SOME slots => + (case locality_index_probe count (fn () => + Inttab.lookup slots relative_idx) of + NONE => keys + | SOME path => + merge_locality_key_sets + (keys, + locality_path_class_keys_with + count pattern path_class path))) + fun retrieve arities path_class () = + fold (add_arity path_class arities) + (locality_int_range (relative_idx + 1) max_arity) + empty_locality_key_set + fun ranked_query arities path_class = + { rank = locality_path_class_rank depth path_class, + actual = pattern, + retrieve = retrieve arities path_class } + in + if relative_idx < 0 then empty_locality_key_set + else + case locality_family_paths_with + count (Context.Proof ctxt) record_name kind head of + NONE => empty_locality_key_set + | SOME depths => + (case locality_index_probe count (fn () => + Inttab.lookup depths depth) of + NONE => empty_locality_key_set + | SOME arities => + map (ranked_query arities) + locality_path_classes_by_rank + |> locality_maximal_rank_keys_with count ctxt) + end - \\Theory transformation adding a new disjoint pair\ - fun add_record_disjoint_pair (rec_name : string) (cA : string) (cB : string) = - Local_Theory.declaration {pervasive=false, syntax=false, pos=Position.none} - (K (add_record_disjoint_pair_generic rec_name cA cB)) + fun locality_entries_for_keys_generic context keys = + let + val entries = RecordLocalityData.get context + fun entry_of key = + (case LocalityOperationalKeyTable.lookup entries key of + SOME entry => entry + | NONE => + error "Stale AutoLocality secondary operational key") + in + map entry_of keys + end - \\Lookup the footprint and disjointness data associated with a record, each as an association list.\ - val get_record_locality_data_generic : Context.generic -> - (Symtab.key * locality_entry) list * - (Symtab.key * disjoint_pair) list - = RecordLocalityData.get #> (apfst Symtab.dest_list o apsnd Symtab.dest_list) + fun describe_locality_dispatch_key + (dispatch_key : locality_dispatch_key) = + quote (#head_name dispatch_key) + ^ " at full application arity " + ^ Int.toString (#arity dispatch_key) + + fun canonical_locality_dispatcher_alias (alias0, alias1) = + if fast_string_ord (alias0, alias1) = GREATER + then alias1 + else alias0 + + type locality_dispatcher_inventory_entry = { + origin: stamp, + source_name: string, + alias: string + } + + fun merge_locality_dispatcher_inventory_entry dispatch_key + (entry0 : locality_dispatcher_inventory_entry, + entry1 : locality_dispatcher_inventory_entry) = + if #origin entry0 <> #origin entry1 then + error ("Conflicting independent AutoLocality dispatchers for " + ^ describe_locality_dispatch_key dispatch_key) + else if #source_name entry0 <> #source_name entry1 then + error ("Inconsistent AutoLocality source dispatcher names for " + ^ describe_locality_dispatch_key dispatch_key) + else + { origin = #origin entry0, + source_name = #source_name entry0, + alias = + canonical_locality_dispatcher_alias + (#alias entry0, #alias entry1) } + + fun insert_locality_dispatcher_alias dispatch_key origin + source_name alias inventory = + LocalityDispatchKeyTable.map_default + (dispatch_key, + { origin = origin, + source_name = source_name, + alias = alias }) + (fn entry => + merge_locality_dispatcher_inventory_entry dispatch_key + (entry, + { origin = origin, + source_name = source_name, + alias = alias })) + inventory + + fun merge_locality_dispatcher_inventories inventories = + LocalityDispatchKeyTable.join + merge_locality_dispatcher_inventory_entry inventories + + \\Local inventory of named generic dispatchers. It contains no theorem payload and + no declaration lineage. A private origin stamp distinguishes transport of one standard + declaration from independently allocated sibling dispatchers. One deterministic alias + per family is enough for \<^verbatim>\[[locality_cancel]]\ to restore a representative after + \<^verbatim>\simp only:\ clears the ambient simpset.\ + structure LocalityDispatcherInventory = Generic_Data + ( + type T = + locality_dispatcher_inventory_entry + LocalityDispatchKeyTable.table; + val empty = LocalityDispatchKeyTable.empty; + val merge = merge_locality_dispatcher_inventories; + ); + + fun locality_dispatcher_entry context dispatch_key = + LocalityDispatchKeyTable.lookup + (LocalityDispatcherInventory.get context) dispatch_key + + fun locality_dispatcher_declared context dispatch_key = + Option.isSome (locality_dispatcher_entry context dispatch_key) + + \\Register the footprint for a new attribute/operation.\ + fun add_record_locality_entry_generic ctxt (rec_name : string) + (entry : locality_entry) context = + let + val _ = + if rec_name = locality_entry_record_name entry then () + else locality_entry_conflict entry "record identities differ" + val replay = + LocalityOperationalKeyTable.defined + (RecordLocalityData.get context) (#key entry) + val dispatch_key = + if locality_entry_kind entry = Locality_Attribute + then locality_dispatch_key_of_entry_opt ctxt entry + else NONE + val _ = locality_pretty_trace ctxt 1 (fn () => + Pretty.text "Registering footprint" + @ [Pretty.brk 1, + Pretty.list "[" "]" (List.map Pretty.str (#footprint entry)), + Pretty.brk 1] + @ Pretty.text "for term" + @ [Pretty.brk 1, Syntax.pretty_term ctxt (#pattern entry), Pretty.brk 1] + @ Pretty.text "for record" @ [Pretty.brk 1, Pretty.str rec_name] + |> Pretty.block) + in + case Exn.capture + (RecordLocalityData.map (insert_locality_entry entry)) context of + Exn.Res context' => + let + val context'' = + if replay then context' + else + LocalitySecondaryIndex.map + (insert_locality_secondary_key_with_dispatch + dispatch_key entry) context' + val ctxt' = Context.proof_of context'' + val _ = + AutoLocality_Instrumentation.record_counters ctxt' (fn () => + let + val counter = + if replay + then AutoLocality_Instrumentation.Lifecycle_Replays + else + AutoLocality_Instrumentation.Lifecycle_Semantic_Insertions + val index_counters = + if replay then [] + else + [(AutoLocality_Instrumentation.Index_Nodes, + if locality_entry_kind entry = Locality_Attribute + then 5 else 4), + (AutoLocality_Instrumentation.Index_Secondary_Insertions, + 1)] + in (counter, 1) :: index_counters end) + in context'' end + | Exn.Exn exn => + if Exn.is_interrupt exn then Exn.reraise exn + else + let + val _ = + AutoLocality_Instrumentation.record_counters ctxt (fn () => + [(AutoLocality_Instrumentation.Lifecycle_Conflicts, 1)]) + in Exn.reraise exn end + end + + \\Lookup the footprint data associated with a record, as an association list.\ + val get_record_locality_data_generic : Context.generic -> (Symtab.key * locality_entry) list + = RecordLocalityData.get + #> LocalityOperationalKeyTable.dest + #> map (fn (key, entry) => (#record_name key, entry)) val get_record_locality_data = Context.Proof #> get_record_locality_data_generic val get_record_locality_data_raw_generic = RecordLocalityData.get \\Get list of records that we manage any footprint information about\ - val get_registered_records = Context.Proof #> RecordLocalityData.get #> fst #> Symtab.keys + val get_registered_records = + Context.Proof + #> LocalitySecondaryIndex.get + #> #records + #> Symtab.keys \\Lookup footprint data for record\ - fun get_record_locality_data_for_record_generic r ctxt : - (locality_entry list * disjoint_pair list) option = + fun get_record_locality_data_for_record_generic r ctxt : locality_entry list option = let - val (consts, pairs) = get_record_locality_data_raw_generic ctxt - val (x_opt, y_opt) = (Symtab.lookup consts r, Symtab.lookup pairs r) + val keys = + Symtab.lookup (#records (LocalitySecondaryIndex.get ctxt)) r + |> Option.map LocalityOperationalKeyTable.keys + val entries = + Option.map (locality_entries_for_keys_generic ctxt) keys in - case (x_opt, y_opt) of - (NONE, NONE) => NONE - | _ => SOME (Option.getOpt (x_opt, []), Option.getOpt (y_opt, [])) + case entries of + SOME (_ :: _) => entries + | _ => NONE end fun get_record_locality_data_for_record r = Context.Proof #> get_record_locality_data_for_record_generic r + fun has_record_locality_data_for_record r ctxt = get_record_locality_data_for_record r ctxt |> Option.isSome \\Lookup all registered attributes for a record\ fun get_attributes ctxt = ctxt |> get_record_locality_data - |> fst - |> List.filter (fn (_, e : locality_entry) => #const_type e = "attribute") - - \\Lookup all registered operations for a record\ - fun get_operations ctxt = ctxt - |> get_record_locality_data - |> fst - |> List.filter (fn (_, e : locality_entry) => #const_type e = "operation") + |> List.filter (fn (_, e : locality_entry) => + locality_entry_kind e = Locality_Attribute) - fun get_record_locality_entry_generic (r : string) (c : string) ctxt = + fun get_record_locality_entries_generic (r : string) ctxt = case get_record_locality_data_for_record_generic r ctxt of - NONE => NONE - | SOME (consts, _) => - List.find (fn {const_name = c0, ...} => c0 = c) consts + NONE => [] + | SOME entries => entries + + fun get_record_locality_entries (r : string) = + Context.Proof #> get_record_locality_entries_generic r + + fun get_record_locality_entries_for_const_generic (r : string) (c : string) ctxt = + let + val keys = + Symtab.lookup (#names (LocalitySecondaryIndex.get ctxt)) r + |> Option.mapPartial (fn names => Symtab.lookup names c) + |> Option.map LocalityOperationalKeyTable.keys + in + keys + |> Option.map (locality_entries_for_keys_generic ctxt) + |> the_default [] + end - fun get_record_locality_entry (r : string) (c : string) = - Context.Proof #> get_record_locality_entry_generic r c + fun get_record_locality_entries_for_const (r : string) (c : string) = + Context.Proof #> get_record_locality_entries_for_const_generic r c - val has_record_locality_entry_generic = Option.isSome ooo get_record_locality_entry_generic + fun has_record_locality_entry_generic r c ctxt = + not (null (get_record_locality_entries_for_const_generic r c ctxt)) + + fun locality_registration_conflict ctxt rec_name pattern detail = + let + val count = locality_direct_counter ctxt + val _ = locality_count_one count + AutoLocality_Instrumentation.Lifecycle_Conflicts + in + error ("Conflicting autolocality registration for " + ^ Syntax.string_of_term ctxt pattern ^ " on " ^ rec_name ^ ": " ^ detail) + end + + fun locality_registration_is_replay ctxt rec_name const_name pattern + flexible_prefix kind footprint args idx field expected_core_count + expected_disjoint_count expect_local_thm = + let + val count = locality_direct_counter ctxt + val _ = locality_count_one count + AutoLocality_Instrumentation.Lifecycle_Registration_Attempts + val _ = locality_count_one count + AutoLocality_Instrumentation.Lookup_Requests + val _ = locality_count_one count + AutoLocality_Instrumentation.Lookup_Index_Probes + val replay_key = locality_replay_key rec_name pattern idx + val candidates = + LocalityReplayKeyTable.lookup + (#replay_slots + (LocalitySecondaryIndex.get (Context.Proof ctxt))) + replay_key + |> Option.map LocalityOperationalKeyTable.keys + |> Option.map + (locality_entries_for_keys_generic (Context.Proof ctxt)) + |> the_default [] + val _ = locality_count_list count + AutoLocality_Instrumentation.Lookup_Entries_Examined candidates + val _ = locality_count_list count + AutoLocality_Instrumentation.Lookup_Candidates_Returned candidates + fun metadata_matches (entry : locality_entry) = + #const_name entry = const_name + andalso locality_entry_kind entry = kind + andalso locality_entry_args entry = args + andalso locality_entry_flexible_prefix entry = flexible_prefix + fun payload_matches (entry : locality_entry) = + eq_set (op =) (#footprint entry, footprint) + andalso #field entry = field + fun entry_is_complete (entry : locality_entry) = + length (#core_thms entry) = expected_core_count + andalso length (#disjoint_thms entry) = expected_disjoint_count + andalso Option.isSome (#local_thm entry) = expect_local_thm + in + case candidates of + [] => false + | [entry] => + if not (metadata_matches entry) then + locality_registration_conflict ctxt rec_name pattern + "role, arity, constant identity, or flexible-prefix metadata differs" + else if not (payload_matches entry) then + locality_registration_conflict ctxt rec_name pattern + "footprint or field metadata differs" + else if not (entry_is_complete entry) then + locality_registration_conflict ctxt rec_name pattern + "the existing registration is incomplete" + else + (locality_count_one count + AutoLocality_Instrumentation.Lifecycle_Replays; + true) + | _ => + locality_registration_conflict ctxt rec_name pattern + "multiple entries occupy the same typed record slot" + end + + fun locality_registration_replay_proof ctxt = + \\Keep the command's trailing proof terminator valid without + publishing another theorem or declaration.\ + Proof.theorem NONE (K I) [] ctxt fun prepare_rec_name (ctxt : Proof.context) (rec_name : string) = let - (* Assumes a type of the form (_, _,..., _) ty and replaces the dummys with free type variables *) + val theory = Proof_Context.theory_of ctxt + \\Replace the type-name parser's arguments with fresh variables while retaining + every sort constraint declared by datatype-record selectors or + standard-record metadata. The bare type-name parser returns dummy + arguments at sort {}, even when the generated constants retain + stronger source-level constraints.\ fun prepare_typ ty = let val (base, args) = Term.dest_Type ty - val argnum = length args - val tvars = Library.map_range (fn i => (TVar (("?'a", i), []))) argnum + val declared_sorts = + (case Ctr_Sugar.ctr_sugar_of ctxt base of + SOME sugar => + (case #selss sugar of + (sel :: _) :: _ => + (case Term.domain_type (Term.type_of sel) of + Type (base', selector_args) => + if base = base' + then map Type.sort_of_atyp selector_args + else replicate (length args) [] + | _ => replicate (length args) []) + | _ => replicate (length args) []) + | NONE => + (case Record.get_info theory base of + SOME info => map snd (#args info) + | NONE => replicate (length args) [])) + fun prepare_arg (i, arg) = + let + val parsed_sort = Type.sort_of_atyp arg handle TYPE _ => [] + val declared_sort = nth declared_sorts i + in + TVar (("?'a", i), + if null parsed_sort then declared_sort else parsed_sort) + end in - Type (base, tvars) + Type (base, map_index prepare_arg args) end - val rec_ty = rec_name + val prepared_rec_ty = rec_name |> Proof_Context.read_type_name {proper = true, strict = false} ctxt |> prepare_typ - val (rec_name_full, _) = rec_ty |> dest_Type + val (rec_name_full, _) = prepared_rec_ty |> dest_Type + val rec_ty = + if Option.isSome (Record.get_info theory rec_name_full) + then Sign.certify_typ_mode Type.mode_default theory prepared_rec_ty + else prepared_rec_ty in (rec_ty, rec_name_full) end \\Pretty printing helper\ - fun pretty_locality_entry ctxt rec_name {const_name=c, const_type=_, footprint=fp, idx=idx, args=_, sp=_} = - let val (rec_ty, _) = prepare_rec_name ctxt rec_name in + fun pretty_locality_entry ctxt rec_name (entry : locality_entry) = + let + val (rec_ty, _) = prepare_rec_name ctxt rec_name + val pattern = #pattern entry + val fp = #footprint entry + val idx = locality_entry_idx entry + in Pretty.text "On record" @ [Pretty.brk 1, Syntax.pretty_typ ctxt rec_ty] @ Pretty.text "," @ [Pretty.brk 1, - Syntax.pretty_term ctxt (Syntax.parse_term ctxt c), Pretty.brk 1] + Syntax.pretty_term ctxt pattern, Pretty.brk 1] @ [Pretty.enclose "(" ")" ( [Pretty.str "arg:", Pretty.str (Int.toString idx)] |> Pretty.breaks), Pretty.brk 1] @@ -203,8 +2159,9 @@ ML\ fun print_locality_data_for_record (ctxt : Proof.context) (rec_name : string) = let val (_, rec_name) = prepare_rec_name ctxt rec_name val data = (get_record_locality_data_for_record_generic rec_name (Context.Proof ctxt) - |> Option.map fst |> curry Option.getOpt) [] - val _ = List.map (pretty_locality_entry ctxt rec_name) data |> Pretty.chunks |> Pretty.writeln + |> curry Option.getOpt) [] + val _ = List.map (pretty_locality_entry ctxt rec_name) data + |> Pretty.chunks |> Pretty.writeln in () end @@ -221,54 +2178,50 @@ ML\ NONE => print_locality_data_for_all_records ctxt | SOME rec_name => print_locality_data_for_record ctxt rec_name); ctxt) - fun list_prod xs = List.map (fn x => List.map (rpair x) xs) #> Library.flat - - \\Lookup pairs of disjoint attributes/operators for a given record\ - fun find_disjoint_pairs_for_record_generic r ctxt = - case get_record_locality_data_for_record_generic r ctxt of - NONE => [] - | SOME (consts, _) => (let - \\Go through all pairs and check if they are disjoint\ - val const_pairs = list_prod consts consts - val disjoint_pairs = List.filter - (fn (({const_name = cA, footprint = footprintA, ...}, - {const_name = cB, footprint = footprintB, ...})) => - cA < cB andalso - List.length (Library.inter (op =) footprintA footprintB) = 0) - const_pairs - in - disjoint_pairs - end) + fun string_to_identifier s = s + |> String.explode |> List.map (fn c => if c = #" " orelse c = #"." then #"_" else c) + |> List.map (fn c => if c = #"'" then #"P" else c) + |> List.filter (fn c => Char.isAlphaNum c orelse c = #"_") + |> String.implode - \\Checks if there is a commutativity lemma registered for constants \<^verbatim>\cA\ and \<^verbatim>\cB\ - operating on record \<^verbatim>\r\.\ - fun has_commutativity_lemma_generic ctxt r cA cB = + fun locality_public_id ctxt pattern = let - val pairs_with_lemma = (get_record_locality_data_for_record_generic r ctxt - |> Option.map snd |> curry Option.getOpt) [] - val (cA, cB) = order_pair (cA, cB) + val cname = extract_const pattern + val has_baked_const = + snd (Term.strip_comb pattern) + |> exists (fn arg => case Term.head_of arg of Const _ => true | _ => false) in - Library.member (op =) pairs_with_lemma (cA, cB) + if has_baked_const + then string_to_identifier (Syntax.pretty_term ctxt pattern |> Pretty.pure_string_of) + else string_to_identifier (Long_Name.base_name cname) end - \\List all pairs of constants operating on a given record and having disjoint footprints, - for which no commutativity lemma has not yet been proved.\ - fun find_disjoint_pairs_without_commutativity_lemma_generic r ctxt = + fun assert_locality_public_id_available ctxt rec_name kind idx public_id pattern = let - val disjoint_pairs = find_disjoint_pairs_for_record_generic r ctxt + val conflicts = + get_record_locality_entries rec_name ctxt + |> List.filter (fn (entry : locality_entry) => + locality_entry_kind entry = kind + andalso locality_entry_idx entry = idx + andalso locality_public_id ctxt (#pattern entry) = public_id + andalso not (locality_registration_pattern_eq ctxt + (#pattern entry, pattern))) in - List.filter (fn ({const_name=cA, const_type=tyA, ...},{const_name=cB, const_type=tyB, ...}) => - (tyA = "operation" orelse tyB = "operation") andalso - (not (has_commutativity_lemma_generic ctxt r cA cB))) - disjoint_pairs + case conflicts of + [] => () + | entry :: _ => + let + val count = locality_direct_counter ctxt + val _ = locality_count_one count + AutoLocality_Instrumentation.Lifecycle_Conflicts + in + error ("Autolocality generated-name collision for " ^ public_id + ^ " on " ^ rec_name ^ " between " + ^ Syntax.string_of_term ctxt (#pattern entry) ^ " and " + ^ Syntax.string_of_term ctxt pattern) + end end - fun string_to_identifier s = s - |> String.explode |> List.map (fn c => if c = #" " orelse c = #"." then #"_" else c) - |> List.map (fn c => if c = #"'" then #"P" else c) - |> List.filter (fn c => Char.isAlphaNum c orelse c = #"_") - |> String.implode - fun register_locality_op_commutativity_thm_name rec_name c = (string_to_identifier rec_name) ^ "_local_op_" ^ c ^ "_core" fun register_locality_op_disjointness_thm_name rec_name c = @@ -280,15 +2233,108 @@ ML\ (rec_name |> string_to_identifier) ^ "_local_attr_" ^ c ^ "_" ^ (Int.toString i) ^ "_core" fun register_locality_attr_cancellation_thm_list_name rec_name c i = (rec_name |> string_to_identifier) ^ "_local_attr_" ^ c ^ "_" ^ (Int.toString i) ^ "_cancel" - fun register_locality_attr_simproc_name rec_name c i = - (rec_name |> string_to_identifier) ^ "_local_attr_" ^ c ^ "_" ^ (Int.toString i) ^ "_simproc" + + \\Physical dispatcher bindings encode the complete long-name component + sequence. Each original component has an indexed byte-length/chunk-count frame followed + by indexed fixed-size hexadecimal payload chunks. The component count and arity have + separate frames, and the fixed base name remains below Isabelle's long-name range limit.\ + val locality_dispatch_hex_payload_limit = 16000 + + fun locality_dispatch_hex_byte byte = + let + val value = Word8.toInt byte + in + hex_digit (value div 16) ^ hex_digit (value mod 16) + end + + fun locality_dispatch_hex_chunks encoded = + let + val encoded_size = size encoded + fun chunks offset = + if offset >= encoded_size then [] + else + let + val chunk_size = + Int.min + (locality_dispatch_hex_payload_limit, + encoded_size - offset) + in + String.substring (encoded, offset, chunk_size) + :: chunks (offset + chunk_size) + end + in + if encoded_size = 0 then [""] else chunks 0 + end + + fun locality_dispatch_name_components + (component_index, component) = + let + val bytes = Byte.stringToBytes component + val encoded = + Word8Vector.foldr + (fn (byte, suffix) => + locality_dispatch_hex_byte byte :: suffix) + [] bytes + |> String.concat + val payloads = locality_dispatch_hex_chunks encoded + val component_index_string = Int.toString component_index + val header = + "c" ^ component_index_string + ^ "_b" ^ Int.toString (Word8Vector.length bytes) + ^ "_n" ^ Int.toString (length payloads) + val payload_components = + payloads + |> map_index (fn (payload_index, payload) => + "c" ^ component_index_string + ^ "_p" ^ Int.toString payload_index + ^ "_" ^ payload) + in + header :: payload_components + end + + fun register_locality_dispatch_simproc_components head_name arity = + let + val _ = + if arity >= 0 then () + else error "Negative AutoLocality dispatcher arity" + val components = Long_Name.explode head_name + val encoded_components = + components + |> map_index locality_dispatch_name_components + |> flat + in + ["autolocality_dispatch_v1", + "k" ^ Int.toString (length components)] + @ encoded_components + @ ["a" ^ Int.toString arity, + "autolocality_locality_dispatch_simproc"] + end + + fun register_locality_dispatch_simproc_name head_name arity = + register_locality_dispatch_simproc_components head_name arity + |> Long_Name.implode + + fun locality_dispatch_simproc_components + (dispatch_key : locality_dispatch_key) = + register_locality_dispatch_simproc_components + (#head_name dispatch_key) (#arity dispatch_key) + + fun locality_dispatch_simproc_binding dispatch_key = + let + val (qualifiers, base_name) = + split_last (locality_dispatch_simproc_components dispatch_key) + in + Binding.name base_name + |> fold_rev (Binding.qualify true) qualifiers + end + + fun locality_dispatch_simproc_name dispatch_key = + locality_dispatch_simproc_binding dispatch_key + |> Binding.long_name_of fun default_named_theorems_for_record (rec_name : string) = (rec_name |> string_to_identifier) ^ "_locality_facts" - fun commutativity_theorems_for_record (rec_name : string) = - (rec_name |> string_to_identifier) ^ "_commutativity_facts" - fun strip_prefix (prefix : string) (s : string) : string option = if String.isPrefix prefix s then SOME (String.extract (s, size prefix, NONE)) @@ -296,245 +2342,22 @@ ML\ NONE val strlist_to_str = String.concatWith ", " - fun field_update rec_name field = rec_name ^ "." ^ "update_" ^ field - fun dest_field_update const = strip_prefix "update_" const + fun dest_field_update const = + let val base = Long_Name.base_name const in + case strip_prefix "update_" base of + SOME field => SOME field + | NONE => try (unsuffix Record.updateN) base + end fun fieldlist_to_str fs = "[" ^ (strlist_to_str fs) ^ "]" - fun is_update_commutativity_thm (t : thm) = - let - val (lhs, rhs) = t |> Thm.prop_of |> HOLogic.dest_Trueprop |> HOLogic.dest_eq - val lhs_hd = lhs |> Term.strip_comb |> fst |> Term.dest_Const |> fst |> Long_Name.base_name - val rhs_hd = rhs |> Term.strip_comb |> fst |> Term.dest_Const |> fst |> Long_Name.base_name - in - case (dest_field_update lhs_hd, dest_field_update rhs_hd) of - (SOME f0, SOME f1) => f0 <> f1 - | _ => false - end handle TERM _ => false - - fun check_create_commutativity_theorems (rec_name : string) ctxt = - case check_create_named_theorems (commutativity_theorems_for_record rec_name) ctxt of - (false, name', ctxt) => (name', ctxt) - | (true, name', ctxt') => let - (* Lookup built-in theorems for record and filter update commutativity relations *) - val record_simps = lookup_thms ctxt' (rec_name ^ ".record_simps") - val update_commutativity_facts = List.filter is_update_commutativity_thm record_simps - val ctxt'' = fold (fn t => Local_Theory.declaration {pervasive=false, syntax=false, pos=Position.none} (Named_Theorems.add_thm name' t |> K)) - update_commutativity_facts ctxt' - in - (name', ctxt'') - end - fun unpack_attributes_default (ctxt : Proof.context) (rec_name : string) attribs_opt = - (("unpack: " ^ rec_name |> tracing); - tap (fn _ => "done") (case attribs_opt of + case attribs_opt of SOME attribs => attribs | NONE => let val default_thms = default_named_theorems_for_record rec_name val attr = Token.explode0 (Thy_Header.get_keywords' ctxt) default_thms - in [attr] end)) - - exception CommutativitySkipException - - fun prove_commutativity_lemma_for_disjoint_operators attribs_opt - (rec_name : string) (cA : string) (cB : string) (ctxt : Proof.context) = - (let - val (rec_ty, rec_name) = prepare_rec_name ctxt rec_name - val (_, _, ctxt) = check_create_named_theorems (default_named_theorems_for_record rec_name) ctxt - val (pA, pB) = (Syntax.read_term ctxt cA, Syntax.read_term ctxt cB) - val _ = - [Pretty.str "Auto-deriving commutativity", - Syntax.pretty_term ctxt pA, - Pretty.str "\", - Syntax.pretty_term ctxt pB, - Pretty.enclose "(" ")" [Pretty.str "on", Pretty.brk 1, Syntax.pretty_typ ctxt rec_ty], - Pretty.str "..."] |> Pretty.breaks |> Pretty.block |> locality_pretty_trace ctxt 0 - - (* Get rid of positioning information that's inherent in p_name since they - are produced by Parse.typ and Parse.term, respectively. Otherwise, the proposition-strings - built below won't be recognized. *) - val (cA, cB) = (cA, cB) |> ((Syntax.read_input #> Input.string_of) |> apply2) - (* Check that the given term is indeed a function on the given record *) - val (_, num_argsA, rec_namexA) = dest_fun_term ctxt rec_ty pA |> Option.valOf - val (_, num_argsB, rec_namexB) = dest_fun_term ctxt rec_ty pB |> Option.valOf - - fun arglist_with_prefix prefix num idx x = - make_arglist_with_prefix prefix num - |> list_set_nth idx x - |> String.concatWith " " - val argsA = arglist_with_prefix "argsA" num_argsA rec_namexA - val argsB = arglist_with_prefix "argsB" num_argsB rec_namexB - - fun call_with_special_arg c prefix num idx x = - c ^ " " ^ arglist_with_prefix prefix num idx ("(" ^ x ^ ")") - val callA = call_with_special_arg cA "argsA" num_argsA rec_namexA - val callB = call_with_special_arg cB "argsB" num_argsB rec_namexB - - (* Build statements of locality lemmas *) - val commutativity_str = - "\" ^ argsA "" ^ " " ^ argsB "" ^ " R . " ^ callA (callB "R") ^ " = " ^ callB (callA "R") - val commutativity_stm = commutativity_str |> Syntax.read_prop ctxt - handle ERROR _ => (let val pre_term = Syntax.parse_term ctxt commutativity_str in - ([Pretty.text "Commutativity proposition" |> Pretty.block, - Syntax.pretty_term ctxt pre_term, - Pretty.text "is ill-typed, probably because of mismatching type arguments in polymorphic record -- ignore" |> Pretty.block] - |> Pretty.breaks |> Pretty.block |> Pretty.string_of |> warning; - raise CommutativitySkipException) end) - - val commutativity_thm_name = (rec_name |> string_to_identifier) ^ "_" ^ cA ^ "_" ^ cB ^ "_commute" - - fun after_qed (named_thm_list_opt) name (cont : Proof.context -> Proof.context) thms ctxt = - let val thms = thms |> flat - val _ = "after qed" |> tracing - val attribs = unpack_attributes_default ctxt rec_name attribs_opt - |> List.map (Attrib.check_src ctxt) - in ctxt - |> (case named_thm_list_opt of - SOME n => fold (fn t => Local_Theory.declaration {pervasive=false, syntax=false, pos=Position.none} (Named_Theorems.add_thm n t |> K)) thms - | NONE => I) - |> Local_Theory.note (((Binding.name name), []), thms) |> snd - |> Local_Theory.note ((Binding.empty,attribs), thms) |> snd - |> cont - end - val cA_id = string_to_identifier cA - val cB_id = string_to_identifier cB + in [attr] end - val cA_local = register_locality_op_local_action_thm_name rec_name cA_id - val cB_local = register_locality_op_local_action_thm_name rec_name cB_id - val cA_comm = register_locality_op_commutativity_thm_name rec_name cA_id - val cB_comm = register_locality_op_commutativity_thm_name rec_name cB_id - - fun get_thm (ctxt : Proof.context) = Facts.named #> Proof_Context.get_fact_single ctxt - - val cA_local_thm = cA_local |> get_thm ctxt - val cB_local_thm = cB_local |> get_thm ctxt - - val commutativity_thms = Named_Theorems.check ctxt - (commutativity_theorems_for_record rec_name, Position.none) - - fun start_core_proof ctxt cont = (ctxt - |> Proof.theorem NONE (after_qed (SOME commutativity_thms) commutativity_thm_name cont) [map (fn t => (t,[])) [commutativity_stm]] - |> apply_context_tactic (K all_tac) - |> apply_context_tactic (fn ctxt => CONVERSION (Conv.bottom_rewrs_conv [cA_local_thm RS eq_reflection] ctxt) 1) - |> apply_context_tactic (fn ctxt => CONVERSION (Conv.bottom_rewrs_conv [cB_local_thm RS eq_reflection] ctxt) 1) - |> apply_txt ctxt ("simp only: " ^ cA_comm ^ " " ^ cB_comm) - |> apply_txt ctxt ("simp") - |> Proof.global_done_proof) - handle ERROR e => - ([[Pretty.str "Something went wrong proving derived commutativity theorem for", - Syntax.pretty_term ctxt pA, - Pretty.str "and", - Syntax.pretty_term ctxt pB, - Pretty.str "."] |> Pretty.breaks |> Pretty.block, - Pretty.str "This can happen if one of the operators is an abbreviation, but otherwise shouldn't.", - ([Pretty.str "This is what I tried to prove (see", - Pretty.here \<^here> |> List.last, Pretty.str "for the ML code)"] |> Pretty.breaks |> Pretty.block), - Syntax.pretty_term ctxt commutativity_stm, - Pretty.str "Original error message:", - Pretty.str e] |> Pretty.chunks |> Pretty.string_of |> warning; raise CommutativitySkipException) - in - start_core_proof ctxt (add_record_disjoint_pair rec_name cA cB) - end) handle CommutativitySkipException => ctxt - - fun prove_commutativity_lemma_for_disjoint_operator_and_attribute attribs_opt - (rec_name : string) (c_op : string) (c_attr : string) (rec_namex_attr : int) (ctxt : Proof.context) = - (let - val (rec_ty, rec_name) = prepare_rec_name ctxt rec_name - val (_, _, ctxt) = check_create_named_theorems (default_named_theorems_for_record rec_name) ctxt - val (p_op, p_attr) = (Syntax.read_term ctxt c_op, Syntax.read_term ctxt c_attr) - val _ = - [Pretty.str "Auto-deriving commutativity", - Syntax.pretty_term ctxt p_op, - Pretty.str "\", - Syntax.pretty_term ctxt p_attr, - Pretty.enclose "(" ")" [Pretty.str "index", Pretty.brk 1, Pretty.str (rec_namex_attr |> Int.toString)], - Pretty.enclose "(" ")" [Pretty.str "on", Pretty.brk 1, Syntax.pretty_typ ctxt rec_ty], - Pretty.str "..."] |> Pretty.breaks |> Pretty.block |> locality_pretty_trace ctxt 0 - - (* Get rid of positioning information that's inherent in p_name and rec_name since they - are produced by Parse.typ and Parse.term, respectively. Otherwise, the proposition-strings - built below won't be recognized. *) - val (c_op, c_attr) = (c_op, c_attr) |> ((Syntax.read_input #> Input.string_of) |> apply2) - (* Check that the given term is indeed a function on the given record *) - val (_, num_args_op, rec_namex_op) = dest_fun_term ctxt rec_ty p_op |> Option.valOf - val (_, num_args_attr, rec_namexs_attr) = dest_attr_term ctxt rec_ty p_attr |> Option.valOf - - val _ = if not (Library.member (op =) rec_namexs_attr rec_namex_attr) then - error ("Illegal argument index " ^ (rec_namex_attr |> Int.toString) ^ - " passed to prove_commutativity_lemma_for_disjoint_operator_and_attribute") - else () - - fun arglist_with_prefix prefix num idx x = - make_arglist_with_prefix prefix num - |> list_set_nth idx x - |> String.concatWith " " - val args_op = arglist_with_prefix "args_op" num_args_op rec_namex_op - val args_attr = arglist_with_prefix "args_attr" num_args_attr rec_namex_attr - - fun call_with_special_arg c prefix num idx x = - c ^ " " ^ arglist_with_prefix prefix num idx ("(" ^ x ^ ")") - val call_op = call_with_special_arg c_op "args_op" num_args_op rec_namex_op - val call_attr = call_with_special_arg c_attr "args_attr" num_args_attr rec_namex_attr - - (* Build statements of locality lemmas *) - val commutativity_str = - "\" ^ args_op "" ^ " " ^ args_attr "" ^ " R . " ^ call_attr (call_op "R") ^ " = " ^ call_attr "R" - - (* The commutativity relation might be ill-typed because for polymorphic types, we only index - by their base type, regardless of the arguments. In case of a type mismatch, print a warning - and skip the pair. *) - val commutativity_stm = commutativity_str |> Syntax.read_prop ctxt - handle ERROR _ => (let val pre_term = Syntax.parse_term ctxt commutativity_str in - ([Pretty.text "Commutativity proposition" |> Pretty.block, - Syntax.pretty_term ctxt pre_term, - Pretty.text "is ill-typed, probably because of mismatching type arguments in polymorphic record -- ignore" |> Pretty.block] - |> Pretty.breaks |> Pretty.block |> Pretty.string_of |> warning; - raise CommutativitySkipException) end) - val commutativity_thm_name = (rec_name |> string_to_identifier) ^ "_" ^ c_op ^ "_" ^ c_attr ^ "_" ^ - (rec_namex_attr |> Int.toString) ^ "_commute" - - fun after_qed (named_thm_list_opt) name (cont : Proof.context -> Proof.context) thms ctxt = - let val thms = thms |> flat - val _ = "after qed2" |> tracing - val attribs = unpack_attributes_default ctxt rec_name attribs_opt - |> List.map (Attrib.check_src ctxt) - in ctxt - |> (case named_thm_list_opt of - SOME n => fold (fn t => Local_Theory.declaration {pervasive=false, syntax=false, pos=Position.none} (Named_Theorems.add_thm n t |> K)) thms - | NONE => I) - |> Local_Theory.note (((Binding.name name), []), thms) |> snd - |> Local_Theory.note ((Binding.empty,attribs), thms) |> snd - |> cont - end - - val c_op_id = string_to_identifier c_op - val c_attr_id = string_to_identifier c_attr - - val c_op_local = register_locality_op_local_action_thm_name rec_name c_op_id - val c_attr_cancel_core = register_locality_attr_cancellation_thm_name rec_name c_attr_id rec_namex_attr - val c_attr_cancel_thms = register_locality_attr_cancellation_thm_list_name rec_name c_attr_id rec_namex_attr - val c_attr_cancel_thms = Named_Theorems.check ctxt (c_attr_cancel_thms, Position.none) - - fun do_proof ctxt cont = (ctxt - |> Proof.theorem NONE (after_qed (SOME c_attr_cancel_thms) commutativity_thm_name cont) [map (fn t => (t,[])) [commutativity_stm]] - |> apply_method (SIMPLE_METHOD all_tac) - |> apply_txt ctxt ("subst " ^ c_op_local) - |> apply_txt ctxt ("simp add: " ^ c_attr_cancel_core) - |> Proof.global_done_proof) - handle ERROR e => - ([[Pretty.str "Something went wrong proving derived commutativity theorem for", - Syntax.pretty_term ctxt p_op, - Pretty.str "and", - Syntax.pretty_term ctxt p_attr, - Pretty.str "."] |> Pretty.breaks |> Pretty.block, - Pretty.str "This can happen if one of the operators is an abbreviation, but otherwise shouldn't.", - ([Pretty.str "This is what I tried to prove (see", - Pretty.here \<^here> |> List.last, Pretty.str "for the ML code)"] |> Pretty.breaks |> Pretty.block), - Syntax.pretty_term ctxt commutativity_stm, - Pretty.str "Original error message:", - Pretty.str e] |> Pretty.chunks |> Pretty.string_of |> warning; raise CommutativitySkipException) - in - do_proof ctxt (add_record_disjoint_pair rec_name c_op c_attr) - end) handle CommutativitySkipException => ctxt \ subsection\Complex hoisting and cancellations using \<^verbatim>\simproc\\ @@ -552,7 +2375,8 @@ text\ complicated to \<^verbatim>\attr (f0 (f1 (f2( ... (g x)))))\ which requires commuting \<^verbatim>\g\ past all \<^verbatim>\f_i\ first before it can be cancelled with \<^verbatim>\attr\. - See \<^file>\AutoLocality_Test0.thy\ for an example of the resulting simproc \<^verbatim>\locality_cancel\. + See \<^file>\AutoLocality_Tests/AutoLocality_Test_Cancel.thy\ for an example of the resulting + simproc \<^verbatim>\locality_cancel\. \ ML\ @@ -560,28 +2384,99 @@ ML\ \\Recursively zooms into an argument of a term, according to a picker function, retaining the previous and following arguments.\ - fun strip_comb_iter (picker : term -> term list -> (int * 'a) option) (t : term) : 'a op_term_with_gap list * term = + fun strip_comb_iter_with count + (picker : term -> term list -> (int * 'a) option) + (t : term) : 'a op_term_with_gap list * term = let - fun core (acc : 'a op_term_with_gap list) (t : term) = + fun core (acc_rev : 'a op_term_with_gap list) (t : term) = let val (head, args) = t |> Term.strip_comb val iter = picker head args in case iter of - NONE => (acc, t) - | SOME (idx, data) => core (acc @ [(data, (head, List.take (args, idx), - List.drop (args, idx+1)))]) (List.nth (args, idx)) + NONE => + let + val _ = locality_count_int count + AutoLocality_Instrumentation.Planner_Tail_Copies + (fn () => length acc_rev) + in (rev acc_rev, t) end + | SOME (idx, data) => + core ((data, (head, List.take (args, idx), + List.drop (args, idx + 1))) :: acc_rev) + (List.nth (args, idx)) end in core [] t end - \\This is a left inverse to \<^verbatim>\strip_comb_iter\\ - fun recombine_decomposed_comb ([], body) = body - | recombine_decomposed_comb (((_, (head, pre, suf)) :: inner), body) = - let val r = recombine_decomposed_comb (inner, body) in - Term.list_comb (head, pre @ [r] @ suf) - end + fun strip_comb_iter picker t = + strip_comb_iter_with locality_no_count picker t + + \\This is a left inverse to \<^verbatim>\strip_comb_iter\\ + fun recombine_decomposed_comb_with _ ([], body) = body + | recombine_decomposed_comb_with count + (((_, (head, pre, suf)) :: inner), body) = + let + val r = recombine_decomposed_comb_with count (inner, body) + val _ = locality_count_int count + AutoLocality_Instrumentation.Planner_Application_Frames + (fn () => length pre + 1 + length suf) + val _ = locality_count_int count + AutoLocality_Instrumentation.Planner_Tail_Copies + (fn () => 2 * length pre + 1) + in + Term.list_comb (head, pre @ [r] @ suf) + end + + fun recombine_decomposed_comb decomp = + recombine_decomposed_comb_with locality_no_count decomp + + fun fun_conv_many (f_conv: conv) (arg_convs: conv list) = + List.foldl (fn (arg, f) => Conv.combination_conv f arg) f_conv arg_convs + + fun arg_convN num_args n conv = + fun_conv_many Conv.all_conv (replicate (Int.max(0,n - 1)) Conv.all_conv @ [conv] @ replicate (num_args - n - 1) Conv.all_conv) + + fun op_term_with_gap_conv ([], _) _ = Conv.all_conv + | op_term_with_gap_conv ((_, (_, pre, post)) :: ls, t) conv = + let val arg_convs = List.map (K Conv.all_conv) pre @ [op_term_with_gap_conv (ls, t) conv] @ List.map (K Conv.all_conv) post + in + fun_conv_many conv arg_convs + end + + fun op_term_with_gap_conv_with count + ([], _) (_: conv) (_: conv -> conv) = + (locality_count_one count + AutoLocality_Instrumentation.Planner_Base_Child_Builds; + Conv.all_conv) + | op_term_with_gap_conv_with count + ((_, (_, pre, post)) :: ls, t) + (conv: conv) (step_conv: conv -> conv) = + let + val _ = locality_count_one count + AutoLocality_Instrumentation.Planner_Recursive_Node_Builds + val _ = locality_count_one count + AutoLocality_Instrumentation.Planner_Context_Lifts + val _ = locality_count_int count + AutoLocality_Instrumentation.Planner_Application_Frames + (fn () => length pre + 1 + length post) + val _ = locality_count_one count + AutoLocality_Instrumentation.Planner_Tail_Copies + val child_conv = + op_term_with_gap_conv_with count (ls, t) conv step_conv + |> Conv.cache_conv + val arg_convs = + List.map (K Conv.all_conv) pre + @ [child_conv] + @ List.map (K Conv.all_conv) post + in + (conv then_conv + (step_conv (Conv.try_conv child_conv))) + else_conv (fun_conv_many Conv.all_conv arg_convs) + end + + fun op_term_with_gap_conv' decomp conv step_conv = + op_term_with_gap_conv_with locality_no_count decomp conv step_conv \ text\A small experiment demonstrating what \<^verbatim>\strip_comb_iter\ does. Here, we always pick @@ -620,32 +2515,216 @@ end\ end ML\ - \\Term picker for use with \<^verbatim>\strip_comb_iter\ which zooms into an operation on a record - for which footprint data has been defined. For example, if \<^verbatim>\f a b r c d\ is an operation - on \<^verbatim>\r :: 'rec\ whose type is a datatype record \<^verbatim>\'rec\, and if \<^verbatim>\f\ has footprint data - registered for \<^verbatim>\'rec\, then this picker would select argument 2 (which is \<^verbatim>\r\) to zoom into.\ - fun locality_picker (ctxt : Proof.context) (rec_name : string) (head : term) (_ : term list) = - (let - val _ = [Pretty.str "Locality simproc, check:", Pretty.str rec_name, Syntax.pretty_term ctxt head] - |> Pretty.breaks |> Pretty.block |> locality_pretty_trace ctxt 1 - val head_str = head |> Term.dest_Const |> fst |> Long_Name.base_name - val lookup = - case get_record_locality_entry rec_name head_str ctxt of - SOME e => SOME e - | NONE => (* Check if we're looking at an in-built update function *) - case dest_field_update head_str of - NONE => NONE - | SOME field => SOME ({ const_name = head_str, const_type = "operation", - args = 2, footprint = [field], idx = 1, sp = NONE } : locality_entry) - in case lookup of - NONE => (Pretty.text ("Could not find entry " ^ head_str ^ " in footprint db for " ^ rec_name) - |> Pretty.block |> locality_pretty_trace ctxt 1; NONE) - | SOME e => (Pretty.text "Found locality entry with footprint" - @ [Pretty.brk 1, Pretty.list "(" ")" (List.map Pretty.str (#footprint e))] - |> Pretty.block |> locality_pretty_trace ctxt 1; - SOME (#idx e, e)) - end) - handle TERM _ => NONE + fun locality_varify_atyps tfrees base = + let + val instantiations = + tfrees |> map_index (fn (i, (name, sort)) => + ((name, sort), TVar ((name, base + i), sort))) + in + fn TFree key => + AList.lookup (op =) instantiations key + |> the_default (TFree key) + | typ => typ + end + + \\Turn fixed type variables into fresh schematic variables while retaining any + schematic variables already introduced by a declaration morphism. Isabelle's + global varifier rejects mixed TFree/TVar terms, which occur for polymorphic + datatype-record fields after local-theory transport.\ + fun locality_varify_typ typ = + let + val tfrees = Term.add_tfreesT typ [] + val base = Term.maxidx_of_typ typ + 1 + in + Term.map_atyps (locality_varify_atyps tfrees base) typ + end + + fun locality_varify_types term = + let + val tfrees = Term.add_tfrees term [] + val base = Term.maxidx_of_term term + 1 + in + Term.map_types + (Term.map_atyps (locality_varify_atyps tfrees base)) term + end + + fun locality_assumption_tfrees ctxt = + fold (fn cterm => Term.add_tfrees (Thm.term_of cterm)) + (Assumption.all_assms_of ctxt) [] + + \\Locale definition equations carry the locale predicate as a hidden theorem + hypothesis. Type frees shared with that predicate must remain fixed while proving the + certificate: schematizing them independently makes the definition equation unusable even + though it is available in the local proof context. Other type frees remain schematic, which + preserves polymorphic registrations and deliberately supports mixed TFree/TVar terms.\ + fun locality_varify_types_preserving protected_tfrees term = + let + val tfrees = + Term.add_tfrees term [] + |> filter_out (member (op =) protected_tfrees) + val base = Term.maxidx_of_term term + 1 + in + Term.map_types + (Term.map_atyps (locality_varify_atyps tfrees base)) term + end + + fun locality_entry_prefix_length (entry : locality_entry) = + length (snd (Term.strip_comb (#pattern entry))) + + fun locality_entry_absolute_idx (entry : locality_entry) = + locality_entry_prefix_length entry + locality_entry_idx entry + + fun locality_entry_match_pattern (entry : locality_entry) = + locality_match_pattern + (#pattern entry) (locality_entry_flexible_prefix entry) + + fun locality_entry_flexible_pairs ctxt (actual : term) (entry : locality_entry) = + locality_pattern_flexible_pairs ctxt actual + (#pattern entry) (locality_entry_flexible_prefix entry) + + fun locality_entry_matches_prefix_with count ctxt + (actual : term) (entry : locality_entry) = + locality_pattern_matches_prefix_with count ctxt actual + (#pattern entry) (locality_entry_flexible_prefix entry) + + fun locality_entry_matches_prefix ctxt actual entry = + locality_entry_matches_prefix_with locality_no_count ctxt actual entry + + \\Locale declarations are transported with the concrete interpretation term that was + supplied to the locale machinery. Isabelle may subsequently print or parse a provably equal + term (for example, @{term Suc} instead of @{term "\n. n + 1"}). Matching such a prefix is + not enough: the stored certificates must also be rewritten to that actual typed prefix before + conversion can consume them. Keep this specialization local to the lookup; the context data + retains the declaration's canonical transported entry.\ + fun locality_specialize_entry_with count ctxt + (actual : term) (entry : locality_entry) : locality_entry = + let + val _ = locality_count_one count + AutoLocality_Instrumentation.Lookup_Specializations + fun prove_rewrite (stored, actual) = + if Term.aconv (stored, actual) then NONE + else SOME (Goal.prove ctxt [] [] (Logic.mk_equals (stored, actual)) + (fn {context, ...} => + asm_full_simp_tac (context addsimps @{thms fun_eq_iff}) 1)) + val rewrites = + locality_entry_flexible_pairs ctxt actual entry + |> map_filter prove_rewrite + fun rewrite_thm thm = + thm + |> Thm.transfer' ctxt + |> fold (fn rewrite => + Conv.fconv_rule + (Conv.try_conv (Conv.bottom_rewrs_conv [rewrite] ctxt))) + rewrites + fun specialize core_thms disjoint_thms local_thm = + { key = #key entry, + const_name = #const_name entry, + pattern = actual, + footprint = #footprint entry, + field = #field entry, + core_thms = core_thms, + disjoint_thms = disjoint_thms, + local_thm = local_thm } + in + if null rewrites then + if Term.aconv (#pattern entry, actual) then entry + else specialize (#core_thms entry) (#disjoint_thms entry) (#local_thm entry) + else specialize + (map rewrite_thm (#core_thms entry)) + (map rewrite_thm (#disjoint_thms entry)) + (Option.map rewrite_thm (#local_thm entry)) + end + + fun locality_specialize_entry ctxt actual entry = + locality_specialize_entry_with locality_no_count ctxt actual entry + + fun locality_entry_matches_application_with count ctxt + (head : term) (args : term list) (entry : locality_entry) = + let + val prefix_length = locality_entry_prefix_length entry + in + length args >= prefix_length + locality_entry_args entry andalso + locality_entry_matches_prefix_with count ctxt + (Term.list_comb (head, List.take (args, prefix_length))) entry + end + + fun locality_entry_matches_application ctxt head args entry = + locality_entry_matches_application_with locality_no_count ctxt head args entry + + fun locality_entries_have_same_effect_with count + (entries : locality_entry list) = + case entries of + [] => true + | entry :: entries' => + fold (fn entry' => fn same_effect => + let + val _ = locality_count_one count + AutoLocality_Instrumentation.Lookup_Comparisons + val same_effect' = + locality_entry_kind entry = locality_entry_kind entry' + andalso locality_entry_absolute_idx entry = + locality_entry_absolute_idx entry' + andalso eq_set (op =) + (#footprint entry, #footprint entry') + in + same_effect andalso same_effect' + end) entries' true + + fun locality_entries_have_same_effect entries = + locality_entries_have_same_effect_with locality_no_count entries + + \\Select the most specific typed registration matching an application. Exact typed + matches take precedence over schematic polymorphic matches, rigid prefixes over flexible + prefixes, and longer registered partial applications over shorter ones. Remaining compatible + duplicates are harmless import-diamond replays. Incompatible matches are rejected instead of + selecting the first entry by constant name.\ + fun select_locality_entry_kind_with count ctxt + (rec_name : string) kind + (head : term) (args : term list) = + let + val context = Context.Proof ctxt + val _ = locality_count_one count + AutoLocality_Instrumentation.Lookup_Requests + val candidates = + locality_application_keys_with + count ctxt rec_name kind head args + |> LocalityOperationalKeyTable.keys + |> locality_entries_for_keys_generic context + val _ = locality_count_list count + AutoLocality_Instrumentation.Lookup_Entries_Examined candidates + val _ = locality_count_list count + AutoLocality_Instrumentation.Lookup_Candidates_Returned candidates + in + case candidates of + [] => NONE + | entry :: _ => + if locality_entries_have_same_effect_with count candidates then + let + val n = locality_entry_prefix_length entry + val actual = Term.list_comb (head, List.take (args, n)) + in + SOME (locality_entry_absolute_idx entry, + locality_specialize_entry_with count ctxt actual entry) + end + else + error ("Ambiguous autolocality registrations on " ^ rec_name) + end + + fun select_locality_entry_with count ctxt rec_name kind_name head args = + select_locality_entry_kind_with count ctxt rec_name + (locality_entry_kind_of_string kind_name) head args + + fun select_locality_entry ctxt rec_name kind_name head args = + select_locality_entry_with locality_no_count ctxt + rec_name kind_name head args + + \\Picker for operations inside an attribute's record telescope.\ + fun locality_operation_picker_with count ctxt rec_name head args = + select_locality_entry_kind_with count ctxt rec_name + Locality_Operation head args + + fun locality_operation_picker ctxt rec_name head args = + locality_operation_picker_with locality_no_count ctxt rec_name head args fun disjoint_footprint (fpA : string list) (fpB : string list) = length (Library.inter (op =) fpA fpB) = 0 @@ -656,12 +2735,31 @@ ML\ fun merge_footprints (fpA : string list) (fpB : string list) = Library.merge (op =) (fpA, fpB) - fun lift_redundant_operations_core front back _ [] = (front, back) - | lift_redundant_operations_core front back fp ((e : locality_entry, f) :: efs) = - if disjoint_footprint fp (#footprint e) then - lift_redundant_operations_core (front @ [(e,f)]) back fp efs - else - lift_redundant_operations_core front (back @ [(e,f)]) (merge_footprints fp (#footprint e)) efs + fun lift_redundant_operations_core_with count front back fp entries = + let + fun core front_rev back_rev _ [] = + let + val _ = locality_count_int count + AutoLocality_Instrumentation.Planner_Tail_Copies + (fn () => length front + length back + + length front_rev + length back_rev) + in + (front @ rev front_rev, back @ rev back_rev) + end + | core front_rev back_rev footprint + ((e : locality_entry, f) :: efs) = + if disjoint_footprint footprint (#footprint e) then + core ((e, f) :: front_rev) back_rev footprint efs + else + core front_rev ((e, f) :: back_rev) + (merge_footprints footprint (#footprint e)) efs + in + core [] [] fp entries + end + + fun lift_redundant_operations_core front back fp entries = + lift_redundant_operations_core_with locality_no_count + front back fp entries \\If the toplevel term is an attribute on a record, look for operations applied to the record argument that can be hoisted out and cancelled. @@ -674,104 +2772,1724 @@ ML\ Note if \<^verbatim>\opB\ had footprint \<^verbatim>\{c, d}\, say, then it could not be hoisted because it does not commute with \<^verbatim>\opA\; hence, as we descend into the term, we have to maintain the union of the footprints of terms we looked at.\ - fun hoist_redundant_operations_core - ((e : locality_entry as {const_type = "attribute", ...}, f) :: inner) = - let val (front, back) = lift_redundant_operations_core [] [] (#footprint e) inner in - (length front = 0, (e,f) :: (front @ back)) + fun hoist_redundant_operations_core_with count + ((e : locality_entry, f) :: inner) = + if locality_entry_kind e = Locality_Attribute then + let + val (front, back) = + lift_redundant_operations_core_with count + [] [] (#footprint e) inner + in + (length front = 0, (e, f) :: (front @ back), + List.map #1 front, List.map #1 back) + end + else (true, (e, f) :: inner, [], []) + | hoist_redundant_operations_core_with _ x = (true, x, [], []) + + fun hoist_redundant_operations_with count (x,y) = + let + val (action, xp, f, b) = + hoist_redundant_operations_core_with count x + in + (action, (xp, y), f, b) + end + + fun hoist_redundant_operations decomp = + hoist_redundant_operations_with locality_no_count decomp + + \\Definition theorem(s) for a constant, if it has one; otherwise the empty list. We must + return an \<^emph>\unconditional\ definition equation, because the cancellation/locality proofs unfold + it in a cleared simpset that cannot discharge side conditions. Two name resolutions can + produce different forms. The fully-qualified name (\<^verbatim>\Foo.bar_def\) avoids grabbing a + same-named constant from another theory — important when several records share a field/op base + name (cf. the qualified-name cases in + \<^verbatim>\AutoLocality_Test_Boundaries\). But inside a locale, the fully-qualified \<^emph>\exported\ def carries + the locale predicate as a premise (\<^verbatim>\locale ?p \ Foo.bar ?p R \ \\), unusable in a cleared + simpset, whereas the \<^emph>\local\ def under the base name is unconditional (\<^verbatim>\bar R \ \\) with the + locale parameter free. So we gather candidates from both the qualified and the base name and + prefer an unconditional one; this fixes locale-local constants while preserving the + cross-theory disambiguation.\ + fun locality_selected_definition ctxt (cname : string) = + if is_const_with_def ctxt cname then + let + fun get nm = + (try (Proof_Context.get_thms ctxt) nm |> the_default []) + |> map (pair nm) + fun unconditional t = null (Logic.strip_imp_prems (Thm.prop_of t)) + fun defines (_, thm) = + Term.exists_subterm + (fn Const (cname', _) => cname = cname' | _ => false) + (Thm.prop_of thm) + val candidates = + get (Thm.def_name cname) + @ get (Thm.def_name (Long_Name.base_name cname)) + |> filter defines + in + case List.filter (unconditional o #2) candidates of + candidate :: _ => SOME candidate + | [] => + (case candidates of + candidate :: _ => SOME candidate + | [] => NONE) + end + else NONE + + fun locality_def_thms_of ctxt cname = + locality_selected_definition ctxt cname + |> Option.map (single o #2) + |> the_default [] + + fun locality_def_fact_name ctxt cname = + locality_selected_definition ctxt cname + |> Option.map #1 + + fun locality_standard_record_hierarchy_with count thy rec_name = + let + val _ = locality_count_one count + AutoLocality_Instrumentation.Record_Hierarchy_Scans + val info = Record.the_info thy rec_name + val parents = + (case #parent info of + NONE => [] + | SOME (_, parent_name) => + locality_standard_record_hierarchy_with count thy parent_name) + in + parents @ [info] + end + + fun locality_standard_record_hierarchy thy rec_name = + locality_standard_record_hierarchy_with locality_no_count thy rec_name + + fun locality_field_selector_names ctxt rec_name = + get_fields_full rec_name ctxt + |> map (Syntax.read_term ctxt #> extract_const) + + fun locality_field_name_lookup kind names field = + case List.find (fn name => Long_Name.base_name name = field) names of + SOME name => name + | NONE => error ("Unknown record " ^ kind ^ " " ^ quote field) + + fun locality_field_selector_name ctxt rec_name field = + locality_field_name_lookup "field" + (locality_field_selector_names ctxt rec_name) field + + fun locality_field_update_name ctxt rec_name field = + case List.find (fn name => dest_field_update name = SOME field) + (get_field_updates_full rec_name ctxt) of + SOME name => name + | NONE => error ("Unknown record field update " ^ quote field) + + \\The field selector/update algebra for datatype records or standard records. + Datatype records expose a dedicated quadratic \<^verbatim>\record_simps\ collection. Standard + records keep per-level simps in `Record.info`; gather only the selected + record's inheritance chain instead of importing the global record + simpset.\ + fun locality_record_simps_of_with count ctxt + (rec_name : string) : thm list = + let + val _ = locality_count_one count + AutoLocality_Instrumentation.Record_Preparations + val thy = Proof_Context.theory_of ctxt + val simps = + case Record.get_info thy rec_name of + NONE => + Attrib.eval_thms ctxt + [(rec_name ^ ".record_simps" |> Facts.named, [])] + | SOME _ => + locality_standard_record_hierarchy_with count thy rec_name + |> maps #simps + |> distinct Thm.eq_thm_prop + val _ = locality_count_list count + AutoLocality_Instrumentation.Record_Rules_Selected simps + in + simps + end + + fun locality_record_simps_of ctxt rec_name = + locality_record_simps_of_with + (locality_direct_counter ctxt) ctxt rec_name + + fun locality_record_expand_thms ctxt rec_name = + let val thy = Proof_Context.theory_of ctxt in + case Record.get_info thy rec_name of + SOME info => [#equality info] + | NONE => Proof_Context.get_thms ctxt (rec_name ^ ".expand") + end + + fun locality_record_expand_thm_name ctxt rec_name = + if Option.isSome (Record.get_info (Proof_Context.theory_of ctxt) rec_name) + then rec_name ^ ".equality" + else rec_name ^ ".expand" + + \\A minimal simpset carrying only the supplied lemmas on top of \<^verbatim>\HOL_ss\, with \<^verbatim>\if\ splitting + enabled. Building on \<^verbatim>\HOL_ss\ rather than the full ambient simpset is the key performance lever: + the record-update algebra goals are pure rewriting, so the classical reasoner and the hundreds + of ambient simp rules are dead weight. + + Two ingredients beyond the bare lemmas are essential. (1) \<^verbatim>\if_split\: an operation whose body + is a top-level conditional (e.g. \<^verbatim>\if c then update_a \ else update_b \\) generates locality + goals with that \<^verbatim>\if\ on both sides; without splitting it, the field algebra cannot normalise + through the branches and the goal survives. (2) \<^verbatim>\HOL_ss\ rather than \<^verbatim>\HOL_basic_ss\: splitting + the \<^verbatim>\if\ in a commutativity/disjointness goal produces residual implications carrying the branch + condition and its negation (e.g. \<^verbatim>\c \ \c \ \\); discharging those needs the \<^verbatim>\if\-congruence and + boolean simplification that \<^verbatim>\HOL_ss\ provides but \<^verbatim>\HOL_basic_ss\ (even with \<^verbatim>\simp_thms\) does + not. \<^verbatim>\HOL_ss\ is still vastly lighter than the old \<^verbatim>\auto\/ambient-simpset approach — measured at + the same speed as \<^verbatim>\HOL_basic_ss\ on the common (non-conditional) field-update goals.\ + fun locality_make_simpset ctxt (simps : thm list) : Proof.context = + let + val count = locality_direct_counter ctxt + val _ = locality_count_one count + AutoLocality_Instrumentation.Record_Simpset_Builds + in + Splitter.add_split @{thm if_split} + (put_simpset HOL_ss ctxt addsimps simps) + end + + \\The (definition-unfolding + \<^verbatim>\record_simps\) lemma list for a record and a set of constants. + This is the expensive lookup — \<^verbatim>\record_simps\ is quadratic in the number of fields — so a + caller proving many goals over the same record should compute it once and reuse it. + + \<^verbatim>\Let_def\ is included because an operation whose body is a \<^verbatim>\let \ in \\ (e.g. + \<^verbatim>\w_apply_policy\, whose body binds a local before the update + telescope) unfolds to a \<^verbatim>\let\ that blocks \<^verbatim>\record_simps\ from reaching the underlying field + updates; without \<^verbatim>\Let_def\ the field algebra cannot normalise through it and the + commutativity/disjointness/local-action goals survive. (The old \<^verbatim>\auto\-based discharge carried + \<^verbatim>\Let_def\ in its simp set for exactly this reason.)\ + fun locality_record_lemmas ctxt (rec_name : string) (cnames : string list) : thm list = + @{thms Let_def} @ maps (locality_def_thms_of ctxt) cnames @ locality_record_simps_of ctxt rec_name + + \\The user-defined constants directly referenced in \<^verbatim>\cname\'s body (one level deep). These are + the helper functions / operations an operation \<^emph>\delegates\ to (e.g. \<^verbatim>\w_split_set\ calls + \<^verbatim>\split_pair\; \<^verbatim>\w_nested\ calls another operation on an inner record). To discharge the + locality goals the field algebra must see through these, so their definitions have to be + unfolded alongside the operation's own. + We restrict to constants in the record's own theory and skip \<^verbatim>\case_*\ combinators (those are + handled by split rules, and unfolding their internal definition would defeat the split).\ + fun locality_body_helper_consts ctxt (rec_name : string) (cname : string) : string list = + let + val rec_thy = Long_Name.qualifier rec_name + val record_field_consts = + locality_field_selector_names ctxt rec_name + @ get_field_updates_full rec_name ctxt + fun same_theory c = + Long_Name.qualifier c = rec_thy orelse Long_Name.qualifier (Long_Name.qualifier c) = rec_thy + (* Constants belonging to the record's own datatype machinery — its selectors, field updates, + constructor, case combinator — live under the '.' namespace. These must NOT be + unfolded as "helpers": their definitions expand to a 'case ' on the record, + which then gets case-split, manufacturing spurious subgoals (e.g. 'update_f g (make_rec \) + = make_rec \'). The record algebra is handled entirely by 'record_simps', so we drop them. *) + fun is_record_machinery c = + Long_Name.qualifier c = rec_name + orelse member (op =) record_field_consts c + val consts = fold (fn d => Term.add_consts (Thm.prop_of d)) (locality_def_thms_of ctxt cname) [] + |> map fst |> distinct (op =) + in + consts |> List.filter (fn c => + c <> cname andalso same_theory c andalso is_const_with_def ctxt c + andalso not (is_record_machinery c) + andalso not (String.isPrefix "case_" (Long_Name.base_name c))) + end + + \\Previously registered helpers already carry linear locality certificates in the + record's locality-facts bundle. Prefer those certificates to unfolding the helper body: a + helper may contain a large fold or update telescope whose raw definition is much harder to + normalize, and unfolding it can hide the exact registered operation pattern before its + certificate fires.\ + fun locality_body_helpers_to_unfold ctxt rec_name cname = + locality_body_helper_consts ctxt rec_name cname + |> List.filter (fn helper => + null (get_record_locality_entries_for_const rec_name helper ctxt)) + + \\Datatype case-split rules (\<^verbatim>\T.split\) for every \<^verbatim>\case_T\ combinator appearing in the bodies of + the given constants. An operation whose body is a \<^verbatim>\case x of \\ (e.g. + \<^verbatim>\maybe_steal_secret_metadata_page_pure\, on a \<^verbatim>\page_theft\) needs \<^verbatim>\page_theft.split\ to push + the surrounding field projection / update through the branches. \<^verbatim>\if\ and \<^verbatim>\prod\ are always + included since \<^verbatim>\if\-bodies and tuple-\<^verbatim>\let\s are common and their split rules are cheap.\ + fun locality_body_case_splits ctxt (cnames : string list) : thm list = + let + fun split_name_of c = + let val b = Long_Name.base_name c in + if String.isPrefix "case_" b then SOME (Long_Name.qualifier c ^ ".split") else NONE end - | hoist_redundant_operations_core x = (true, x) + val consts = fold (fn cn => fold (fn d => Term.add_consts (Thm.prop_of d)) + (locality_def_thms_of ctxt cn)) cnames [] + |> map fst |> distinct (op =) + val names = map_filter split_name_of consts + in + @{thms if_split prod.split} + @ maps (fn n => (Proof_Context.get_thms ctxt n) handle ERROR _ => []) names + end + + \\A minimal simpset (as \<^verbatim>\locality_make_simpset\) extended with the case-split rules relevant to the + bodies of \<^verbatim>\cnames\. Used by the declaration-time discharge so that conditional / tuple-let / + datatype-case operation bodies normalise.\ + fun locality_make_split_simpset ctxt (simps : thm list) (cnames : string list) : Proof.context = + locality_make_simpset ctxt simps |> fold Splitter.add_split (locality_body_case_splits ctxt cnames) + + \\Names of the same case-split rules, for use in method strings (\<^verbatim>\auto split: \\). Mirrors + \<^verbatim>\locality_body_case_splits\ but returns fact names rather than theorems.\ + fun locality_body_case_split_names ctxt (cnames : string list) : string list = + let + fun split_name_of c = + let val b = Long_Name.base_name c in + if String.isPrefix "case_" b then SOME (Long_Name.qualifier c ^ ".split") else NONE + end + val consts = fold (fn cn => fold (fn d => Term.add_consts (Thm.prop_of d)) + (locality_def_thms_of ctxt cn)) cnames [] + |> map fst |> distinct (op =) + val names = map_filter split_name_of consts + in + ["if_split", "prod.split"] + @ List.filter (fn n => can (Proof_Context.get_thms ctxt) n) names + end + + \\The record's accumulating \<^verbatim>\_locality_facts\ bundle, if it exists. This carries the + already-derived locality lemmas of \<^emph>\previously registered\ operations, which is exactly what + lets an operation that \<^emph>\delegates\ to another (e.g. one whose body calls a previously + registered operation) be discharged: the callee's facts normalise the inner call. Empty if the + bundle has not been created yet.\ + fun locality_facts_bundle ctxt (rec_name : string) : thm list = + (Named_Theorems.get ctxt (Named_Theorems.check ctxt (default_named_theorems_for_record rec_name, Position.none))) + handle ERROR _ => [] + + \\General-purpose discharge for a locality goal, used as the fallback when the fast minimal \<^verbatim>\simp\ + leaves a residue. This mirrors the old (pre-rewrite) discharge — full \<^verbatim>\auto\ with case + splitting (for \<^verbatim>\if\ / \<^verbatim>\case\ / tuple-\<^verbatim>\let\ bodies), the operation/record lemmas, and the + record's locality-facts bundle (for delegation to other operations) — but is invoked only on the + goals the cheap path could not close, so it is no longer on the hot path of wide-record + initialisation (which proves no per-field-update lemmas at all). \<^verbatim>\intro_thms\ are added as + introduction rules (e.g. \<^verbatim>\rec.expand\ for the local-action goal).\ + fun locality_auto_tac ctxt (rec_name : string) (cnames : string list) (intro_thms : thm list) : tactic = + let + val count = locality_direct_counter ctxt + val _ = locality_count_one count + AutoLocality_Instrumentation.Record_Simpset_Builds + val ctxt' = + ctxt addsimps + (locality_record_lemmas ctxt rec_name cnames + @ locality_facts_bundle ctxt rec_name) + |> fold Splitter.add_split (locality_body_case_splits ctxt cnames) + in auto_tac (ctxt' addSIs intro_thms) end + + \\Tactic discharging a record equality by unfolding the given constant definitions and the + record's \<^verbatim>\record_simps\. This is the workhorse for the on-the-fly cancellation simproc — it + reduces "unfold the operations, normalise the field algebra". It deliberately uses a \<^emph>\cleared\ + simpset (no ambient rules, no congruences, no other simprocs): the simproc calls this from + inside a running \<^verbatim>\simp\, so anything in the ambient set could loop or re-enter the locality + simprocs. Do not switch this to \<^verbatim>\HOL_basic_ss\/the ambient simpset — see the declaration-time + tactics below for the faster \<^verbatim>\HOL_basic_ss\ variants used outside the simproc.\ + fun locality_simp_defs_tac ctxt (rec_name : string) (cnames : string list) : tactic = + let + val count = locality_direct_counter ctxt + val _ = locality_count_one count + AutoLocality_Instrumentation.Record_Simpset_Builds + in + simp_tac + (clear_simpset ctxt addsimps + (locality_record_lemmas ctxt rec_name cnames)) 1 + end + + \\Tactic for the 'local action' lemma \<^verbatim>\op ... R = update_ (\_. field (op ... R)) R\. + This is a record equality that is in general only provable by record extensionality + (\<^verbatim>\rec.expand\): an operation may set a field with a function of the \<^emph>\old\ value (e.g. + \<^verbatim>\update_f (\old. g old)\), and the two sides agree only because that old value is itself the + current field. So we reduce to field equalities by \<^verbatim>\rec.expand\, then normalise each with the + field algebra. Covers both bare field updates and genuine operations. + + Performance: the old implementation used \<^verbatim>\auto_tac\ with \<^verbatim>\rec.expand\ as an introduction rule + over the full ambient simpset, which is ~9x slower per goal than resolving \<^verbatim>\expand\ explicitly + and finishing with a minimal \<^verbatim>\simp\. We try a \<^verbatim>\simp\-only attempt first (for the common case + where both sides are already syntactically equal record updates and \<^verbatim>\expand\ is unnecessary), + then fall back to resolving \<^verbatim>\expand\ and discharging the resulting field equalities. + + The simp-only attempt is wrapped in \<^verbatim>\SOLVED'\: an operation that writes a field with a function + of the \<^emph>\old\ value (e.g. \<^verbatim>\update_qc (\old. old + qc R)\) does \<^emph>\not\ close by rewriting alone — + \<^verbatim>\simp\ partially normalises but leaves the two update-functions provably-but-not-syntactically + equal. Without \<^verbatim>\SOLVED'\ that partial success would short-circuit the \<^verbatim>\ORELSE\ and the residual + goal would escape, so \<^verbatim>\Goal.prove\ would fail and the footprint entry would never be registered.\ + fun locality_local_action_tac ctxt (rec_name : string) (cnames : string list) : tactic = + let + val ss = locality_make_split_simpset ctxt (locality_record_lemmas ctxt rec_name cnames) cnames + val expand = locality_record_expand_thms ctxt rec_name + in + SOLVED' (asm_full_simp_tac ss) 1 + ORELSE SOLVED' (resolve_tac ctxt expand THEN_ALL_NEW asm_full_simp_tac ss) 1 + \\Build the (expensive) \<^verbatim>\auto\ simpset lazily — only if the two cheap \<^verbatim>\simp\ attempts above + both fail — so the common case never pays for it.\ + ORELSE (fn st => locality_auto_tac ctxt rec_name cnames expand st) + end + + fun locality_transfer_thms ctxt = + map (Thm.transfer' ctxt) + + fun locality_entry_certificates ctxt (entry : locality_entry) = + locality_transfer_thms ctxt (#core_thms entry @ #disjoint_thms entry) + + fun locality_certificate_thms ctxt (entries : locality_entry list) = + entries + |> maps (locality_entry_certificates ctxt) + |> distinct Thm.eq_thm_prop + + fun locality_local_rewrites ctxt (entries : locality_entry list) = + entries + |> map_filter #local_thm + |> locality_transfer_thms ctxt + |> distinct Thm.eq_thm_prop + |> map (fn thm => thm RS @{thm eq_reflection}) + + fun locality_meta_rewrites ctxt thms = + thms + |> locality_transfer_thms ctxt + |> map (fn thm => thm RS @{thm eq_reflection}) + + fun locality_rewrs_conv [] = Conv.all_conv + | locality_rewrs_conv thms = Conv.rewrs_conv thms + + fun locality_bottom_rewrs_conv [] _ = Conv.all_conv + | locality_bottom_rewrs_conv thms ctxt = Conv.bottom_rewrs_conv thms ctxt + + fun locality_field_core_rewrites record_simps (entry : locality_entry) = + if locality_entry_kind entry <> Locality_Operation + orelse not (#field entry) then [] + else + record_simps |> map_filter (fn thm => + capture_noninterrupt (fn () => + let + val rewrite = thm RS @{thm eq_reflection} + val lhs_head = rewrite |> Thm.lhs_of |> Thm.term_of |> extract_const + val rhs_head = rewrite |> Thm.rhs_of |> Thm.term_of |> extract_const + val entry_name = #const_name entry + val _ = + if Option.isSome (dest_field_update lhs_head) + andalso Option.isSome (dest_field_update rhs_head) + andalso lhs_head <> rhs_head + then () + else raise Match + in + if lhs_head = entry_name then rewrite + else if rhs_head = entry_name then rewrite RS @{thm Pure.symmetric} + else raise Match + end)) + + fun locality_core_rewrites ctxt record_simps entries = + let + val declared = + entries |> maps #core_thms |> distinct Thm.eq_thm_prop + |> locality_meta_rewrites ctxt + val fields = + entries |> maps (locality_field_core_rewrites record_simps) + in + Library.merge Thm.eq_thm_prop (declared, fields) + end + + fun locality_core_update_field thm = + capture_noninterrupt (fn () => + thm |> Thm.rhs_of |> Thm.term_of |> extract_const |> dest_field_update |> the) + + fun locality_filter_core_rewrites fields = + List.filter (fn thm => + case locality_core_update_field thm of + SOME field => member (op =) fields field + | NONE => false) + + fun locality_operation_applier (entry : locality_entry) prefix = + let + val operation = #pattern entry + val args = locality_entry_args entry + val idx = locality_entry_idx entry + val argtys = Term.binder_types (Term.type_of operation) |> take args + val frees = map_index (fn (i, ty) => Free (prefix ^ Int.toString i, ty)) argtys + in + (nth argtys idx, + fn rec_arg => Term.list_comb (operation, + map_index (fn (i, fr) => if i = idx then rec_arg else fr) frees)) + end + + fun locality_entry_pattern_at_record_type ctxt + (entry : locality_entry) record_type = + let + val fresh_inc = Term.maxidx_of_typ record_type + 1 + val pattern = + #pattern entry + |> locality_varify_types_preserving + (locality_assumption_tfrees ctxt) + |> Term.map_types (Logic.incr_tvar fresh_inc) + val arg_types = + Term.binder_types (Term.type_of pattern) + |> take (locality_entry_args entry) + val source_record_type = + nth arg_types (locality_entry_idx entry) + val type_env = + Sign.typ_match (Proof_Context.theory_of ctxt) + (source_record_type, record_type) Vartab.empty + handle Type.TYPE_MATCH => + error ("Cannot specialize AutoLocality pattern " + ^ Syntax.string_of_term ctxt (#pattern entry) + ^ " at record type " + ^ Syntax.string_of_typ ctxt record_type) + val pattern' = Envir.subst_term_types type_env pattern + val arg_types' = + Term.binder_types (Term.type_of pattern') + |> take (locality_entry_args entry) + in + (pattern', arg_types') + end + + \\Derive one generic attribute/operation cancellation theorem from the two entries' + linear certificates. Apply an operation's self-referential `_local` theorem only once, + immediately cancel the resulting footprint updates, and generalize the result. Expanding a + complete telescope before cancellation duplicates its inner record term once per footprint + field and is therefore exponential even though the final equality is small.\ + fun locality_prove_cancellation_entries_with count ctxt rec_name + (attribute : locality_entry) (operation : locality_entry) = + (case Exn.capture (fn () => + let + val (operation_record_type, apply_operation) = + locality_operation_applier operation "operation_" + val record = Free ("R", operation_record_type) + val operation_result = apply_operation record + val (attribute_out, attribute_out_arg_types) = + locality_entry_pattern_at_record_type ctxt attribute + (Term.type_of operation_result) + val (attribute_in, attribute_in_arg_types) = + locality_entry_pattern_at_record_type ctxt attribute + operation_record_type + val attribute_idx = locality_entry_idx attribute + val _ = + (attribute_out_arg_types ~~ attribute_in_arg_types) + |> map_index (fn (i, (out_type, in_type)) => + if i = attribute_idx orelse out_type = in_type then () + else error "Attribute non-record argument types do not agree") + val attribute_args = + map_index (fn (i, typ) => + Free ("attribute_" ^ Int.toString i, typ)) + attribute_out_arg_types + fun apply_attribute pattern rec_arg = + Term.list_comb (pattern, + map_index (fn (i, arg) => + if i = attribute_idx then rec_arg else arg) + attribute_args) + val lhs = apply_attribute attribute_out operation_result + val expected_rhs = apply_attribute attribute_in record + val (attribute_head, lhs_args) = Term.strip_comb lhs + val attribute_absolute_idx = + locality_entry_absolute_idx attribute + val attribute_gap = + (attribute, + (attribute_head, + List.take (lhs_args, attribute_absolute_idx), + List.drop (lhs_args, attribute_absolute_idx + 1))) + val operation_expansion = + if #field attribute then [] + else locality_local_rewrites ctxt [operation] + val _ = + if #field attribute orelse #field operation + orelse not (null operation_expansion) + then () + else error "Operation has no local-action certificate" + val cancellation_thms = + if #field attribute + then Library.merge Thm.eq_thm_prop + (#disjoint_thms operation, + locality_record_simps_of_with count ctxt rec_name) + else #core_thms attribute + val cancellation_rewrites = + locality_meta_rewrites ctxt cancellation_thms + val _ = + if null cancellation_rewrites + then error "No attribute/operation cancellation certificates" + else () + fun descend_attribute child_conv = + let + val (_, (_, pre, post)) = attribute_gap + val _ = locality_count_one count + AutoLocality_Instrumentation.Planner_Recursive_Node_Builds + val _ = locality_count_one count + AutoLocality_Instrumentation.Planner_Context_Lifts + val _ = locality_count_int count + AutoLocality_Instrumentation.Planner_Application_Frames + (fn () => length pre + 1 + length post) + val _ = locality_count_one count + AutoLocality_Instrumentation.Planner_Tail_Copies + in + fun_conv_many Conv.all_conv + (map (K Conv.all_conv) pre @ [child_conv] + @ map (K Conv.all_conv) post) + end + val expand_operation = + if null operation_expansion then Conv.all_conv + else descend_attribute + (locality_rewrs_conv operation_expansion) + val cancel_operation = + Conv.repeat_conv + (locality_rewrs_conv cancellation_rewrites) + val _ = locality_count_one count + AutoLocality_Instrumentation.Proof_Cterms + val result = + (expand_operation then_conv cancel_operation) + (Thm.cterm_of ctxt lhs) + val actual_rhs = result |> Thm.rhs_of |> Thm.term_of + val _ = + if Term.aconv_untyped (actual_rhs, expected_rhs) then () + else error "Attribute/operation cancellation produced the wrong result" + in + result + |> Thm.forall_intr_frees + |> Thm.forall_elim_vars 0 + end) () of + Exn.Res thm => + (locality_count_one count + AutoLocality_Instrumentation.Proof_Results; + SOME thm) + | Exn.Exn exn => + if Exn.is_interrupt exn then Exn.reraise exn + else + (locality_pretty_trace ctxt 1 (fn () => + Pretty.text "AutoLocality pair cancellation declined:" + @ [Pretty.brk 1, Pretty.str (Runtime.exn_message exn)] + |> Pretty.block); + NONE)) + + \\Derive one operation/operation commutativity theorem from the two entries' linear + certificates. This is deliberately proved in the invocation context and never registered: + cancellation asks only for the back/front swaps required by the current telescope.\ + fun locality_prove_commutativity_entries_with count ctxt rec_name + (entryA : locality_entry) (entryB : locality_entry) : thm option = + (case capture_noninterrupt (fn () => + let + val (rty, appA) = locality_operation_applier entryA "a_" + val (_, appB) = locality_operation_applier entryB "b_" + val R = Free ("R", rty) + val goal = + HOLogic.mk_Trueprop (HOLogic.mk_eq (appA (appB R), appB (appA R))) + in + Goal.prove ctxt [] [] goal + (fn {context, ...} => + let + val simps = locality_certificate_thms context [entryA, entryB] + @ locality_record_simps_of_with count context rec_name + val local_rewrites = + locality_local_rewrites context [entryA, entryB] + val _ = locality_count_one count + AutoLocality_Instrumentation.Record_Simpset_Builds + in + (if null local_rewrites then all_tac + else CONVERSION + (Conv.bottom_rewrs_conv local_rewrites context) 1) + THEN simp_tac (clear_simpset context addsimps simps) 1 + end) + end) of + NONE => NONE + | SOME thm => + (locality_count_one count + AutoLocality_Instrumentation.Proof_Results; + SOME thm)) + + fun locality_prove_commutativity_entries ctxt rec_name entryA entryB = + locality_prove_commutativity_entries_with + (locality_direct_counter ctxt) ctxt rec_name entryA entryB + + \\Fast path for a requested hoist: expand the cancellable front operations with their + `_local` certificates and normalize both the original and hoisted telescopes with only the + relevant `_core` field commutations and record algebra. This avoids deriving an explicit + operation/operation theorem for the common single-field shape. Multi-field and deeper shapes + that do not converge to the same normal form fall through to direct on-demand swaps.\ + fun locality_prove_hoisting_by_normalization_with count ctxt rec_name ctm + ctm_decomposed ctm_decomposed_hoisted + (front_entries : locality_entry list) (back_entries : locality_entry list) = + capture_noninterrupt (fn () => + let + val record_simps = + locality_record_simps_of_with count ctxt rec_name + val front_locality = locality_local_rewrites ctxt front_entries + val back_locality = locality_local_rewrites ctxt back_entries + val front_footprint = front_entries |> maps #footprint |> distinct (op =) + val back_footprint = back_entries |> maps #footprint |> distinct (op =) + val front_commutativity = + locality_core_rewrites ctxt record_simps front_entries + |> locality_filter_core_rewrites back_footprint + val back_commutativity = + locality_core_rewrites ctxt record_simps back_entries + |> locality_filter_core_rewrites front_footprint + val ctxt_clear = clear_simpset ctxt + val _ = locality_count_int count + AutoLocality_Instrumentation.Record_Simpset_Builds (fn () => 3) + val ctxt_record_simps = ctxt_clear addsimps record_simps + val ctxt_front_commutativity = ctxt_clear addsimps front_commutativity + val ctxt_back_commutativity = ctxt_clear addsimps back_commutativity + val inner_conv = + locality_bottom_rewrs_conv back_locality ctxt + then_conv Simplifier.rewrite ctxt_front_commutativity + then_conv Simplifier.rewrite ctxt_record_simps + fun telescope_conv decomp = + op_term_with_gap_conv_with count decomp + (locality_rewrs_conv front_locality) + (Conv.combination_conv (Conv.arg_conv inner_conv)) + val _ = locality_count_one count + AutoLocality_Instrumentation.Proof_Cterms + val ctm_hoisted = + ctm_decomposed_hoisted + |> recombine_decomposed_comb_with count + |> Thm.cterm_of ctxt + val original_reduce = + (telescope_conv ctm_decomposed + then_conv Simplifier.rewrite ctxt_back_commutativity) ctm + val hoisted_reduce = + telescope_conv ctm_decomposed_hoisted ctm_hoisted + val _ = locality_count_int count + AutoLocality_Instrumentation.Proof_Compositions (fn () => 2) + val result = + (hoisted_reduce RS @{thm Pure.symmetric}) + RS (original_reduce RS @{thm Pure.transitive}) + val _ = + if Term.aconv (result |> Thm.rhs_of |> Thm.term_of, Thm.term_of ctm_hoisted) + then () + else error "Autolocality normalization produced the wrong hoisted telescope" + val _ = locality_count_one count + AutoLocality_Instrumentation.Proof_Results + in result end) + + fun locality_prove_hoisting_by_normalization ctxt rec_name ctm + ctm_decomposed ctm_decomposed_hoisted front_entries back_entries = + locality_prove_hoisting_by_normalization_with + (locality_direct_counter ctxt) ctxt rec_name ctm + ctm_decomposed ctm_decomposed_hoisted front_entries back_entries + + \\Rewrite an operation telescope to its stable footprint partition by applying only the + adjacent operation/operation swaps selected by the planner. Every operation occurrence is + tagged with its original position, so identical operations remain distinguishable and both + front and back partitions retain source order. + + A swap is applied at its exact telescope position. The conversion follows the unique record + argument path through the attribute and the already-fixed outer operations, rewrites the + adjacent pair once, and returns. It never asks the simplifier to normalize a complete + telescope and never scans the whole term for a matching pair. Generic commutativity theorems + are memoized by their exact typed operation patterns for the duration of this callback.\ + fun locality_prove_hoisting_by_exact_swaps_with count ctxt rec_name ctm + ctm_decomposed ctm_decomposed_hoisted = + capture_noninterrupt (fn () => + let + val (entries, body) = ctm_decomposed + val (hoisted_entries, hoisted_body) = ctm_decomposed_hoisted + val (attribute_gap, operation_gaps) = + (case entries of + attribute_gap :: operation_gaps => + (attribute_gap, operation_gaps) + | [] => error "Missing attribute in autolocality telescope") + val attribute = fst attribute_gap + val indexed_operations = + operation_gaps + |> map_index (fn (index, gap) => (index, gap)) + + fun stable_partition _ [] front_rev back_rev = + (rev front_rev, rev back_rev) + | stable_partition blocked + ((occurrence as (_, (entry : locality_entry, _))) :: rest) + front_rev back_rev = + if disjoint_footprint blocked (#footprint entry) + then + stable_partition blocked rest + (occurrence :: front_rev) back_rev + else + stable_partition + (merge_footprints blocked (#footprint entry)) + rest front_rev (occurrence :: back_rev) + val (front, back) = + stable_partition (#footprint attribute) + indexed_operations [] [] + val target = front @ back + val target_term = + recombine_decomposed_comb + (attribute_gap :: map #2 target, body) + val expected_hoisted = + recombine_decomposed_comb ctm_decomposed_hoisted + val _ = + if Term.aconv (body, hoisted_body) + andalso Term.aconv (target_term, expected_hoisted) + andalso length entries = length hoisted_entries + then () + else error "Exact AutoLocality swap plan disagrees with hoisting" + + fun same_specialized_entry + (entry0 : locality_entry, entry1 : locality_entry) = + locality_entry_slot_eq (entry0, entry1) + andalso Term.aconv (#pattern entry0, #pattern entry1) + fun lookup_swap _ _ [] = NONE + | lookup_swap back_entry front_entry + (((back0, front0), rewrite) :: rest) = + if same_specialized_entry (back_entry, back0) + andalso same_specialized_entry (front_entry, front0) + then SOME rewrite + else lookup_swap back_entry front_entry rest + fun derive_swap back_entry front_entry memo = + (case lookup_swap back_entry front_entry memo of + SOME rewrite => (rewrite, memo) + | NONE => + let + val theorem = + (case locality_prove_commutativity_entries_with count + ctxt rec_name back_entry front_entry of + SOME result => result + | NONE => + error + "Failed to derive exact AutoLocality adjacent swap") + val _ = locality_count_one count + AutoLocality_Instrumentation.Planner_Swaps + val _ = locality_count_one count + AutoLocality_Instrumentation.Proof_Compositions + val rewrite = + theorem + |> Thm.forall_intr_frees + |> Thm.forall_elim_vars 0 + |> (fn generalized => + generalized RS @{thm eq_reflection}) + in + (rewrite, + ((back_entry, front_entry), rewrite) :: memo) + end) + + fun lift_to_exact_position [] rewrite = Conv.rewr_conv rewrite + | lift_to_exact_position + ((_, (_, pre, post)) :: outer) rewrite = + let + val _ = locality_count_one count + AutoLocality_Instrumentation.Planner_Recursive_Node_Builds + val _ = locality_count_one count + AutoLocality_Instrumentation.Planner_Context_Lifts + val _ = locality_count_int count + AutoLocality_Instrumentation.Planner_Application_Frames + (fn () => length pre + 1 + length post) + val _ = locality_count_one count + AutoLocality_Instrumentation.Planner_Tail_Copies + val child = + lift_to_exact_position outer rewrite + in + fun_conv_many Conv.all_conv + (map (K Conv.all_conv) pre + @ [child] + @ map (K Conv.all_conv) post) + end + + fun swap_adjacent index current current_ctm accumulated memo = + let + val (left_occurrence, right_occurrence) = + (nth current index, nth current (index + 1)) + val (_, (back_entry, _)) = left_occurrence + val (_, (front_entry, _)) = right_occurrence + val _ = + if disjoint_entries back_entry front_entry then () + else error "AutoLocality planned a non-commuting adjacent swap" + val (rewrite, memo') = + derive_swap back_entry front_entry memo + val outer = + attribute_gap + :: map #2 (List.take (current, index)) + val step = + lift_to_exact_position outer rewrite current_ctm + val (prefix, suffix) = chop index current + val current' = + (case suffix of + left :: right :: rest => + prefix @ right :: left :: rest + | _ => error "Malformed AutoLocality adjacent swap") + val expected = + recombine_decomposed_comb + (attribute_gap :: map #2 current', body) + val _ = + if Term.aconv + (step |> Thm.rhs_of |> Thm.term_of, expected) + then () + else error "Exact AutoLocality swap rewrote the wrong position" + val _ = locality_count_one count + AutoLocality_Instrumentation.Planner_Swap_Applications + val _ = locality_count_one count + AutoLocality_Instrumentation.Proof_Compositions + val accumulated' = Thm.transitive accumulated step + in + (current', Thm.rhs_of step, accumulated', memo') + end + + fun bubble target_index current_index state = + if current_index = target_index then state + else + let + val (current, current_ctm, accumulated, memo) = state + val state' = + swap_adjacent (current_index - 1) + current current_ctm accumulated memo + in + bubble target_index (current_index - 1) state' + end + fun arrange target_index state = + if target_index = length target then state + else + let + val wanted = fst (nth target target_index) + val (current, _, _, _) = state + val current_index = + find_index (fn (occurrence, _) => + occurrence = wanted) current + val _ = + if current_index >= target_index then () + else error "AutoLocality lost a planned operation occurrence" + val state' = bubble target_index current_index state + in + arrange (target_index + 1) state' + end + + val initial = + (indexed_operations, ctm, Conv.all_conv ctm, []) + val (actual, actual_ctm, result, _) = arrange 0 initial + val _ = + if map fst actual = map fst target + andalso + Term.aconv + (Thm.term_of actual_ctm, expected_hoisted) + then () + else error "Exact AutoLocality swaps did not reach the target" + in + result + end) + + \\Prove exactly one requested telescope cancellation by conversion. Derive only the + operation/operation swaps needed to move the cancellable front operations across the blocked + back operations, rewrite the original telescope to the already-computed hoisted telescope, + derive one attribute/operation cancellation rule per distinct operational key and actual typed + operation pattern, and schedule those invocation-local rules in front-operation order. Apply + each scheduled rule once at the registered attribute root, lifting it only across any + unregistered trailing application arguments. No user definition is unfolded and no pairwise + theorem is registered or cached.\ + fun locality_prove_cancellation_with count ctxt rec_name ctm + ctm_decomposed ctm_decomposed_hoisted + (front_entries : locality_entry list) (expected_rhs : term) = + (case Exn.capture (fn () => + let + val _ = locality_count_one count + AutoLocality_Instrumentation.Planner_Requests + val _ = locality_count_list count + AutoLocality_Instrumentation.Planner_Cancellations front_entries + val attr_entry = + case fst ctm_decomposed of + (entry, _) :: _ => entry + | [] => error "Missing attribute in autolocality telescope" + + val _ = locality_count_one count + AutoLocality_Instrumentation.Proof_Cterms + val ctm_hoisted = + ctm_decomposed_hoisted + |> recombine_decomposed_comb_with count + |> Thm.cterm_of ctxt + val original_to_hoisted = + if Term.aconv (Thm.term_of ctm, Thm.term_of ctm_hoisted) + then Conv.all_conv ctm + else + case locality_prove_hoisting_by_exact_swaps_with count + ctxt rec_name ctm + ctm_decomposed ctm_decomposed_hoisted of + SOME thm => thm + | NONE => raise Match + val actual_hoisted = original_to_hoisted |> Thm.rhs_of |> Thm.term_of + val _ = + if Term.aconv (actual_hoisted, Thm.term_of ctm_hoisted) then () + else error "Autolocality swaps did not produce the expected hoisted telescope" + + fun typed_cancellation_pattern (operation : locality_entry) = + #pattern operation |> Envir.beta_eta_contract + fun lookup_cancellation memo (operation : locality_entry) = + (case LocalityOperationalKeyTable.lookup memo (#key operation) of + NONE => NONE + | SOME typed_rewrites => + Termtab.lookup typed_rewrites + (typed_cancellation_pattern operation)) + fun insert_cancellation (operation : locality_entry) rewrite = + LocalityOperationalKeyTable.map_default + (#key operation, Termtab.empty) + (Termtab.update_new + (typed_cancellation_pattern operation, rewrite)) + fun make_schedule [] _ schedule_rev = rev schedule_rev + | make_schedule (operation :: operations) memo schedule_rev = + let + val (rewrite, memo') = + (case lookup_cancellation memo operation of + SOME rewrite => (rewrite, memo) + | NONE => + let + val rewrite = + case locality_prove_cancellation_entries_with count + ctxt rec_name attr_entry operation of + SOME thm => thm + | NONE => raise Match + in + (rewrite, + insert_cancellation operation rewrite memo) + end) + in + make_schedule operations memo' (rewrite :: schedule_rev) + end + val cancellation_schedule = + make_schedule front_entries + LocalityOperationalKeyTable.empty [] + val attribute_registered_arity = + locality_entry_prefix_length attr_entry + + locality_entry_args attr_entry + fun apply_root_rewrite rewrite current = + let + val actual_arity = + current + |> Thm.term_of + |> Term.strip_comb + |> snd + |> length + val suffix_arity = + actual_arity - attribute_registered_arity + val _ = + if suffix_arity >= 0 then () + else + error + "AutoLocality cancellation lost the registered attribute root" + val _ = locality_count_int count + AutoLocality_Instrumentation.Planner_Application_Frames + (fn () => suffix_arity) + in + fun_conv_many (Conv.rewr_conv rewrite) + (replicate suffix_arity Conv.all_conv) current + end + fun apply_schedule [] _ accumulated = accumulated + | apply_schedule (rewrite :: rewrites) current accumulated = + let + val step = apply_root_rewrite rewrite current + in + apply_schedule rewrites (Thm.rhs_of step) + (Thm.transitive accumulated step) + end + val hoisted_to_cancelled = + apply_schedule cancellation_schedule ctm_hoisted + (Conv.all_conv ctm_hoisted) + val _ = locality_count_list count + AutoLocality_Instrumentation.Planner_Root_Rewrites + cancellation_schedule + val _ = locality_count_one count + AutoLocality_Instrumentation.Proof_Compositions + val result = + hoisted_to_cancelled + RS (original_to_hoisted RS @{thm Pure.transitive}) + val actual_rhs = result |> Thm.rhs_of |> Thm.term_of + val _ = + (* Dropping a polymorphic datatype-record update can change only + phantom type instantiations on the surrounding attribute. The + recombined expected telescope records the intended constant/free + shape but may retain the pre-cancellation instantiation; the + conversion result itself is the kernel-checked, well-typed RHS. *) + if Term.aconv_untyped (actual_rhs, expected_rhs) then () + else error "Autolocality conversion produced an unexpected right-hand side" + val _ = locality_count_one count + AutoLocality_Instrumentation.Proof_Results + in result end) () of + Exn.Res result => SOME result + | Exn.Exn exn => + if Exn.is_interrupt exn then Exn.reraise exn + else + (locality_pretty_trace ctxt 1 (fn () => + Pretty.text "Autolocality cancellation proof declined:" + @ [Pretty.brk 1, Pretty.str (Runtime.exn_message exn)] + |> Pretty.block); + NONE)) + + fun locality_prove_cancellation ctxt rec_name ctm + ctm_decomposed ctm_decomposed_hoisted + front_entries expected_rhs = + locality_prove_cancellation_with + (locality_direct_counter ctxt) ctxt rec_name ctm + ctm_decomposed ctm_decomposed_hoisted + front_entries expected_rhs + + fun select_locality_entry_for_pattern_kind_with count + ctxt rec_name kind pattern = + let + val context = Context.Proof ctxt + val _ = locality_count_one count + AutoLocality_Instrumentation.Lookup_Requests + val candidates = + locality_pattern_keys_with + count ctxt rec_name kind pattern + |> LocalityOperationalKeyTable.keys + |> locality_entries_for_keys_generic context + val _ = locality_count_list count + AutoLocality_Instrumentation.Lookup_Entries_Examined candidates + val _ = locality_count_list count + AutoLocality_Instrumentation.Lookup_Candidates_Returned candidates + in + case candidates of + [] => NONE + | entry :: _ => + if locality_entries_have_same_effect_with count candidates + then SOME (locality_specialize_entry_with count ctxt pattern entry) + else error ("Ambiguous autolocality pattern on " ^ rec_name) + end + + fun select_locality_entry_for_pattern_with count + ctxt rec_name kind_name pattern = + select_locality_entry_for_pattern_kind_with count ctxt rec_name + (locality_entry_kind_of_string kind_name) pattern + + fun select_locality_entry_for_pattern ctxt rec_name kind_name pattern = + select_locality_entry_for_pattern_with + (locality_direct_counter ctxt) ctxt rec_name kind_name pattern - fun hoist_redundant_operations (x,y) = - let val (action, xp) = hoist_redundant_operations_core x in - (action, (xp, y)) + fun select_locality_entry_for_pattern_at_idx_kind_with count + ctxt rec_name kind pattern idx = + let + val context = Context.Proof ctxt + val _ = locality_count_one count + AutoLocality_Instrumentation.Lookup_Requests + val candidates = + locality_pattern_at_idx_keys_with + count ctxt rec_name kind pattern idx + |> LocalityOperationalKeyTable.keys + |> locality_entries_for_keys_generic context + val _ = locality_count_list count + AutoLocality_Instrumentation.Lookup_Entries_Examined candidates + val _ = locality_count_list count + AutoLocality_Instrumentation.Lookup_Candidates_Returned candidates + in + case candidates of + [] => NONE + | entry :: _ => + if locality_entries_have_same_effect_with count candidates + then SOME (locality_specialize_entry_with count ctxt pattern entry) + else error ("Ambiguous autolocality pattern on " ^ rec_name) + end + + fun select_locality_entry_for_pattern_at_idx_with count + ctxt rec_name kind_name pattern idx = + select_locality_entry_for_pattern_at_idx_kind_with count ctxt rec_name + (locality_entry_kind_of_string kind_name) pattern idx + + fun select_locality_entry_for_pattern_at_idx + ctxt rec_name kind_name pattern idx = + select_locality_entry_for_pattern_at_idx_with + (locality_direct_counter ctxt) + ctxt rec_name kind_name pattern idx + + \\Auto-derive the pairwise commutativity theorem for two registered operations on a record: + \<^verbatim>\opA argsA (opB argsB R) = opB argsB (opA argsA R)\, with the non-record arguments held as fixed + fresh frees and the record threaded through the registered argument position of each. + + This is \<^emph>\sound by construction\: \<^verbatim>\Goal.prove\ returns a theorem only if the proof closes, so a + pair that does not actually commute yields \<^verbatim>\NONE\ rather than a false 'theorem'. Two operations + commute when their footprints are disjoint, because a registered footprint is a read-\<^emph>\and\-write + footprint: an operation's \<^verbatim>\_core\ lemma only proves at registration if it neither reads nor + writes any field outside its footprint, so disjoint-footprint operations cannot observe or + clobber each other. Operations sharing a field (e.g. two writers of the same field) genuinely + do not commute and are correctly declined. + + The operation \<^emph>\names\ may be short or qualified; they are resolved to the fully-qualified + constant the footprint database is keyed under. Unlike the old eager generator, nothing is + registered or stored - the caller decides what to do with the returned theorem. How this is + best surfaced (a command, an attribute, an on-the-fly simproc for op-over-op telescopes) is + left open; this is the core derivation.\ + fun locality_prove_commutativity ctxt (rec_name0 : string) (patternA : term) (patternB : term) + : thm option = + let + val count = locality_direct_counter ctxt + in + capture_noninterrupt (fn () => let + val (_, rec_name) = prepare_rec_name ctxt rec_name0 + fun entry_of pattern = + case select_locality_entry_for_pattern_kind_with count + ctxt rec_name Locality_Operation pattern of + SOME entry => entry + | NONE => error "No matching operation footprint registration" + val eA = entry_of patternA + val eB = entry_of patternB + in + case locality_prove_commutativity_entries_with count + ctxt rec_name eA eB of + SOME thm => thm + | NONE => error "Failed to derive operation commutativity" + end) end - \\simproc identifying cancellable or hoistable subexpressions in a term, and - eliminating them.\ - fun locality_cancellation_simproc rec_name attr_name attr_idx ctxt ctm = + \\simproc identifying cancellable subexpressions in a term, and eliminating them. + + Given a term \<^verbatim>\attr (op1 (op2 ... (opn r) ...))\ where \<^verbatim>\attr\ is a registered attribute and + the \<^verbatim>\opi\ are registered operations, we identify those operations whose footprint is disjoint + from everything between them and \<^verbatim>\attr\ (so they can be hoisted out and then cancelled against + \<^verbatim>\attr\). We compute the cancelled right-hand side directly from the telescope, then prove the + equality \<^verbatim>\lhs = rhs\ ad hoc via \<^verbatim>\locality_prove_eq\. No conversion choreography or pre-generated + commutativity lemmas are needed.\ + fun decompose_locality_telescope_with count + ctxt rec_name (attribute : locality_entry) lhs = let - val _ = + val (head, args) = Term.strip_comb lhs + in + if locality_entry_matches_application_with count + ctxt head args attribute then + let + val idx = locality_entry_absolute_idx attribute + val record_term = nth args idx + val (operations, body) = + strip_comb_iter_with count + (locality_operation_picker_with count ctxt rec_name) record_term + val attribute_gap = + (attribute, (head, List.take (args, idx), List.drop (args, idx + 1))) + in (attribute_gap :: operations, body) end + else ([], lhs) + end + + fun decompose_locality_telescope ctxt rec_name attribute lhs = + decompose_locality_telescope_with + (locality_direct_counter ctxt) ctxt rec_name attribute lhs + + fun locality_cancellation_for_entry_with count + rec_name (attribute0 : locality_entry) ctxt ctm = + (case Exn.capture (fn () => let + val lhs = Thm.term_of ctm + val (head, args) = Term.strip_comb lhs + val prefix_length = locality_entry_prefix_length attribute0 + val attribute = + if length args >= prefix_length + then locality_specialize_entry_with count ctxt + (Term.list_comb (head, List.take (args, prefix_length))) attribute0 + else attribute0 + val _ = locality_pretty_trace ctxt 1 (fn () => [Pretty.text "Locality simproc for" - @ [Pretty.brk 1, Pretty.list "(" ")" [Pretty.str rec_name, Pretty.str attr_name], + @ [Pretty.brk 1, + Pretty.list "(" ")" [Pretty.str rec_name, Pretty.str (#const_name attribute)], Pretty.brk 1, Pretty.str "called"] |> Pretty.block, - [Pretty.str "Term:", Pretty.brk 1, Syntax.pretty_term ctxt (Thm.term_of ctm)] |> Pretty.block] - |> Pretty.chunks |> Pretty.writeln - val ctxt' = clear_simpset ctxt - val lookup_facts = (fn s => (s, Position.none)) #> Named_Theorems.check ctxt #> Named_Theorems.get ctxt + [Pretty.str "Term:", Pretty.brk 1, Syntax.pretty_term ctxt lhs] + |> Pretty.block] + |> Pretty.chunks) + + val ctm_decomposed = + decompose_locality_telescope_with count + ctxt rec_name attribute lhs (* Identify redundant operations in the body of the attribute and hoist them out *) - val (no_op, ctm_decomposed_hoisted) = ctm - |> Thm.term_of - \\Build up 'telescope' of operations on \<^verbatim>\rec_name\\ - |> strip_comb_iter (locality_picker ctxt rec_name) - |> hoist_redundant_operations + val (no_op, ctm_decomposed_hoisted, front_entries, back_entries) = ctm_decomposed + |> hoist_redundant_operations_with count + + \\Helper function to pretty-print the result of \<^verbatim>\strip_comb_iter\\ + fun print_strip_comb_iter_result (ctxt : Proof.context) + ([], t) = [Syntax.pretty_term ctxt t] + | print_strip_comb_iter_result ctxt ((entry, (cur, pre, post)) :: ls, t) = + Pretty.fbreaks ([[Syntax.pretty_term ctxt cur, Pretty.brk 1, Pretty.enclose "\INFO: " "\" [pretty_locality_entry ctxt rec_name entry]] |> Pretty.block] + @ List.map (Syntax.pretty_term ctxt) pre + @ [Pretty.block (print_strip_comb_iter_result ctxt (ls, t))] + @ List.map (Syntax.pretty_term ctxt) post) + + val _ = locality_pretty_trace ctxt 1 (fn () => + print_strip_comb_iter_result ctxt ctm_decomposed |> Pretty.block) + val _ = locality_pretty_trace ctxt 1 (fn () => + print_strip_comb_iter_result ctxt ctm_decomposed_hoisted |> Pretty.block) in if no_op then NONE else let - val ctm_hoisted = ctm_decomposed_hoisted - |> recombine_decomposed_comb - |> Thm.cterm_of ctxt + (* The hoisted telescope is (attr :: front @ back, body), where 'front' are the + cancellable (disjoint) operations. Dropping them gives the cancelled telescope, + and recombining yields the desired right-hand side. *) + val cancelled_decomp = + case ctm_decomposed_hoisted of + (attr_gap :: rest, body) => (attr_gap :: List.drop (rest, length front_entries), body) + | x => x + val rhs = recombine_decomposed_comb_with count cancelled_decomp + + val _ = locality_pretty_trace ctxt 1 (fn () => + [Pretty.str "Cancelled RHS:", Pretty.brk 1, Syntax.pretty_term ctxt rhs] + |> Pretty.block) + in + case locality_prove_cancellation_with count ctxt rec_name ctm + ctm_decomposed ctm_decomposed_hoisted + front_entries rhs of + NONE => NONE + | SOME thm => + (let val _ = locality_pretty_trace ctxt 1 (fn () => + [Pretty.str "Final equation:", Pretty.brk 1, + Syntax.pretty_term ctxt (Thm.prop_of thm)] + |> Pretty.block) + in SOME thm end) + end end) () of + Exn.Res result => result + | Exn.Exn exn => + if Exn.is_interrupt exn then Exn.reraise exn + else + (locality_pretty_trace ctxt 1 (fn () => + Pretty.text "locality cancellation declined after exception:" + @ [Pretty.brk 1, Pretty.str (Runtime.exn_message exn)] + |> Pretty.block); + NONE)) + + fun locality_cancellation_for_entry rec_name attribute ctxt ctm = + locality_cancellation_for_entry_with + (locality_direct_counter ctxt) rec_name attribute ctxt ctm + + fun locality_cancellation_simproc_for_entry rec_name attribute ctxt ctm = + if not (Config.get ctxt locality_cancel_enabled) then NONE + else + locality_with_callback ctxt (fn count => + locality_cancellation_for_entry_with count + rec_name attribute ctxt ctm) + + \\Compatibility entry point used by the ML regression harness. Simprocs installed by + declarations close over only their family dispatch key and do not use this + name-based lookup.\ + fun locality_cancellation_simproc rec_name attr_name idx ctxt ctm = + if not (Config.get ctxt locality_cancel_enabled) then NONE + else + locality_with_callback ctxt (fn count => + let + val context = Context.Proof ctxt + val parsed_const = + try (Syntax.read_term ctxt #> extract_const) attr_name + val (head, args) = ctm |> Thm.term_of |> Term.strip_comb + fun name_matches (entry : locality_entry) = + #const_name entry = attr_name + orelse Long_Name.base_name (#const_name entry) = Long_Name.base_name attr_name + orelse parsed_const = SOME (#const_name entry) + val _ = locality_count_one count + AutoLocality_Instrumentation.Lookup_Requests + val lookup_names = + attr_name :: Long_Name.base_name attr_name + :: the_list parsed_const + val keys = + locality_keys_for_names_with count context rec_name lookup_names + |> LocalityOperationalKeyTable.keys + val entries = + locality_entries_for_keys_generic context keys + val _ = locality_count_list count + AutoLocality_Instrumentation.Lookup_Entries_Examined entries + val candidates = + entries + |> List.filter (fn (entry : locality_entry) => + locality_entry_kind entry = Locality_Attribute + andalso name_matches entry) + |> List.filter + (locality_entry_matches_application_with count ctxt head args) + val max_prefix = + fold (fn entry => fn n => + Int.max (locality_entry_prefix_length entry, n)) candidates 0 + val candidates = + candidates + |> List.filter (fn entry => + locality_entry_prefix_length entry = max_prefix) + val _ = locality_count_list count + AutoLocality_Instrumentation.Lookup_Candidates_Returned candidates + in + case try (nth candidates) idx of + NONE => NONE + | SOME entry => + let + val n = locality_entry_prefix_length entry + val actual = Term.list_comb (head, List.take (args, n)) + in + locality_cancellation_for_entry_with count rec_name + (locality_specialize_entry_with count ctxt actual entry) + ctxt ctm + end + end) + + fun locality_prove_cancellation_fact ctxt (rec_name0 : string) + (operation_pattern : term) (attribute_pattern : term) + (attribute_relative_idx : int) + : thm option = + let + val count = locality_direct_counter ctxt + in + capture_noninterrupt (fn () => + let + val (_, rec_name) = prepare_rec_name ctxt rec_name0 + val operation = + case select_locality_entry_for_pattern_kind_with count + ctxt rec_name Locality_Operation operation_pattern of + SOME entry => entry + | NONE => error "No matching operation footprint registration" + val attribute_absolute_idx = + length (snd (Term.strip_comb attribute_pattern)) + + attribute_relative_idx + val attribute = + case select_locality_entry_for_pattern_at_idx_kind_with count + ctxt rec_name Locality_Attribute + attribute_pattern attribute_absolute_idx of + SOME entry => entry + | NONE => error "No matching attribute footprint registration" + val (operation_record_type, apply_operation) = + locality_operation_applier operation "operation_" + val (attribute_record_type, apply_attribute) = + locality_operation_applier attribute "attribute_" + val _ = + if operation_record_type = attribute_record_type then () + else error "Operation and attribute record types do not agree" + val record = Free ("R", operation_record_type) + val _ = locality_count_one count + AutoLocality_Instrumentation.Proof_Cterms + val ctm = + record + |> apply_operation + |> apply_attribute + |> Thm.cterm_of ctxt + in + case locality_cancellation_for_entry_with count + rec_name attribute ctxt ctm of + SOME thm => + (locality_count_one count + AutoLocality_Instrumentation.Proof_Compositions; + thm RS @{thm meta_eq_to_obj_eq}) + | NONE => error "Failed to derive operation/attribute cancellation" + end) + end - val _ = [ Pretty.str "Hoisted:", Pretty.brk 1, Syntax.pretty_term ctxt (Thm.term_of ctm_hoisted)] - |> Pretty.block |> locality_pretty_trace ctxt 1 + fun locality_dispatch_canonical_type typ = + let + fun add_variable (T as TVar _) = insert (op =) T + | add_variable (T as TFree _) = insert (op =) T + | add_variable _ = I + fun variable_sort (TVar (_, sort)) = sort + | variable_sort (TFree (_, sort)) = sort + | variable_sort _ = + error "Non-variable type in AutoLocality dispatcher scheme" + val variables = + Term.fold_atyps add_variable typ [] + |> sort Term_Ord.typ_ord + val instantiations = + variables |> map_index (fn (i, variable) => + (variable, + TVar (("locality_dispatch_type", i), + variable_sort variable))) + fun canonicalize atyp = + AList.lookup (op =) instantiations atyp + |> the_default atyp + in + Term.map_atyps canonicalize typ + end - (* Simplifying the original and hoisted term should lead to the same result. The resulting - equalities are connected to give an equality between the original and the hoisted term. *) + fun locality_dispatch_trigger ctxt + (dispatch_key : locality_dispatch_key) = + let + val thy = Proof_Context.theory_of ctxt + val head_type = + Sign.the_const_type thy (#head_name dispatch_key) + |> locality_dispatch_canonical_type + val argument_types = Term.binder_types head_type + val _ = + if length argument_types = #arity dispatch_key then () + else + error ("Stale AutoLocality dispatcher arity for " + ^ describe_locality_dispatch_key dispatch_key) + val arguments = + argument_types |> map_index (fn (i, typ) => + Var (("locality_dispatch_arg", i), typ)) + val trigger = + Term.list_comb + (Const (#head_name dispatch_key, head_type), arguments) + |> Envir.beta_eta_contract + val _ = + if null (Term.add_tfrees trigger []) + andalso null (Term.add_frees trigger []) + then () + else + error ("AutoLocality dispatcher trigger captures fixed variables for " + ^ describe_locality_dispatch_key dispatch_key) + in + trigger + end - val commutativity_thms = Named_Theorems.check ctxt - (commutativity_theorems_for_record rec_name, Position.none) + fun locality_dispatch_key_of_trigger trigger : locality_dispatch_key = + let + val (head, arguments) = + trigger + |> Envir.beta_eta_contract + |> Term.strip_comb + in + { head_name = locality_rigid_head_name head, + arity = length arguments } + end - val locality_facts = commutativity_thms |> lookup_facts - val ctm_reduce_eq = Simplifier.rewrite (ctxt' addsimps locality_facts) ctm - val ctm_hoisted_reduce_eq = - Simplifier.rewrite (ctxt' addsimps locality_facts) ctm_hoisted RS @{thm Pure.symmetric} + fun locality_dispatch_witness ctxt dispatch_key = + locality_dispatch_trigger ctxt dispatch_key + |> Thm.cterm_of ctxt + |> Drule.mk_term + |> Thm.trim_context + + fun locality_cancellation_simproc_for_dispatch + dispatch_key ctxt ctm = + if not (Config.get ctxt locality_cancel_enabled) then NONE + else + locality_with_callback ctxt (fn count => + let + val context = Context.Proof ctxt + val actual = Thm.term_of ctm + val _ = locality_count_one count + AutoLocality_Instrumentation.Lookup_Requests + val queries = + locality_dispatch_ranked_key_queries_with + count ctxt dispatch_key actual + + fun try_entries [] = NONE + | try_entries (entry :: entries) = + (case locality_cancellation_for_entry_with count + (locality_entry_record_name entry) entry ctxt ctm of + NONE => try_entries entries + | result => result) + + fun try_queries [] = NONE + | try_queries + ((query : locality_ranked_key_query) :: queries') = + let + val keys = + #retrieve query () + |> locality_equality_valid_keys_with + count ctxt (#actual query) + in + if LocalityOperationalKeyTable.is_empty keys then + try_queries queries' + else + let + val entries = + keys + |> LocalityOperationalKeyTable.keys + |> locality_entries_for_keys_generic context + val _ = locality_count_list count + AutoLocality_Instrumentation.Lookup_Entries_Examined + entries + val _ = locality_count_list count + AutoLocality_Instrumentation.Lookup_Candidates_Returned + entries + in + \\The first nonempty equality-valid rank shadows every + lower rank, even when all of its cancellation + attempts decline.\ + try_entries entries + end + end + in + try_queries queries + end) - val _ = [ Pretty.str "Simplification original:", Pretty.brk 1, - Syntax.pretty_term ctxt (Thm.prop_of ctm_reduce_eq)] - |> Pretty.block |> locality_pretty_trace ctxt 1 - val _ = [ Pretty.str "Simplification hoisted:", Pretty.brk 1, - Syntax.pretty_term ctxt (Thm.prop_of ctm_hoisted_reduce_eq)] - |> Pretty.block |> locality_pretty_trace ctxt 1 + fun locality_simproc_binding dispatch_key = + locality_dispatch_simproc_binding dispatch_key - val ctm_to_ctm_hoisted_eq = ctm_hoisted_reduce_eq RS (ctm_reduce_eq RS @{thm Pure.transitive}) + fun locality_simproc_spec ctxt dispatch_key identifier : + (term, morphism -> Simplifier.proc, thm list) + Simplifier.simproc_spec = + let + val count = locality_direct_counter ctxt + val trigger = locality_dispatch_trigger ctxt dispatch_key + val _ = locality_count_one count + AutoLocality_Instrumentation.Proof_Cterms + val simproc_binding = locality_simproc_binding dispatch_key + val _ = locality_pretty_trace ctxt 0 (fn () => + Pretty.text ("Creating locality dispatcher for ") + @ [Pretty.str (describe_locality_dispatch_key dispatch_key), + Pretty.brk 1, Syntax.pretty_term ctxt trigger] + |> Pretty.block) + in + { passive = false, + name = simproc_binding, + kind = Simproc, + lhss = [trigger], + proc = fn _ => + locality_cancellation_simproc_for_dispatch dispatch_key, + identifier = [identifier] } + end - val _ = [ Pretty.str "Original -> Hoisted:", - Pretty.brk 1, Syntax.pretty_term ctxt (Thm.prop_of ctm_to_ctm_hoisted_eq)] - |> Pretty.block |> locality_pretty_trace ctxt 1 + type locality_entry_descriptor = { + record_name: string, + kind: locality_entry_kind, + const_name: string, + flexible_prefix: bool list, + footprint: string list, + args: int, + idx: int, + field: bool, + core_count: int, + disjoint_count: int, + has_local: bool + } - (* Now, cancel the hoisted operations. It's important that we don't pass the locality_factss here, - as that might undo the hoisting. *) - val cancellation_facts = register_locality_attr_cancellation_thm_list_name rec_name attr_name attr_idx |> lookup_facts - val _ = "Cancellation facts:" |> tracing - val _ = List.map (Thm.prop_of #> Syntax.pretty_term ctxt #> Pretty.writeln) cancellation_facts - val _ = "Done" |> tracing - val ctm_hoisted_cancel_eq = Simplifier.rewrite (ctxt' addsimps cancellation_facts) ctm_hoisted + fun locality_entry_descriptor (entry : locality_entry) : + locality_entry_descriptor = + { record_name = locality_entry_record_name entry, + kind = locality_entry_kind entry, + const_name = #const_name entry, + flexible_prefix = locality_entry_flexible_prefix entry, + footprint = #footprint entry, + args = locality_entry_args entry, + idx = locality_entry_idx entry, + field = #field entry, + core_count = length (#core_thms entry), + disjoint_count = length (#disjoint_thms entry), + has_local = Option.isSome (#local_thm entry) } + + fun locality_entry_fact_bundle lthy (entry : locality_entry) = + map Thm.trim_context + (Drule.mk_term (Thm.cterm_of lthy (#pattern entry)) + :: (#core_thms entry @ #disjoint_thms entry + @ the_list (#local_thm entry))) + + fun locality_trim_morphism context phi = + Morphism.set_trim_context'' context phi + + fun morph_locality_entry_bundle_with psi + (descriptor : locality_entry_descriptor) facts0 : locality_entry = + let + val facts = Morphism.fact psi facts0 + val (pattern_fact, certificate_facts) = + (case facts of + fact :: facts' => (fact, facts') + | [] => error "Missing autolocality operational-pattern witness") + val pattern = Thm.term_of (Drule.dest_term pattern_fact) + val (core_thms0, certificate_facts') = + chop (#core_count descriptor) certificate_facts + val (disjoint_thms0, local_facts) = + chop (#disjoint_count descriptor) certificate_facts' + val finish = Thm.trim_context + val local_thm = + (case (#has_local descriptor, local_facts) of + (false, []) => NONE + | (true, [thm]) => SOME (finish thm) + | _ => error "Malformed autolocality certificate bundle") in - SOME (ctm_hoisted_cancel_eq RS (ctm_to_ctm_hoisted_eq RS @{thm Pure.transitive})) - end end - handle ERROR e => (Pretty.text "locality_cancellation_simproc for" - @ [Pretty.brk 1, Pretty.str rec_name, Pretty.brk 1, Pretty.str attr_name, Pretty.brk 1] - @ Pretty.text "failed with error" @ [Pretty.brk 1, Pretty.str e] - |> Pretty.block |> Pretty.string_of |> warning; NONE) + make_locality_entry + (#record_name descriptor) (#kind descriptor) + (#const_name descriptor) pattern + (#flexible_prefix descriptor) (#footprint descriptor) + (#args descriptor) (#idx descriptor) (#field descriptor) + (map finish core_thms0) (map finish disjoint_thms0) local_thm + end + + fun morph_locality_entry_bundle context phi descriptor facts0 = + morph_locality_entry_bundle_with + (locality_trim_morphism context phi) descriptor facts0 + + fun replay_locality_dispatcher_name dispatch_key origin source_name + binding phi context = + let + val ctxt = Context.proof_of context + val alias = + Name_Space.full_name (Name_Space.naming_of context) + (Morphism.binding phi binding) + val _ = + Simplifier.the_simproc ctxt alias + handle ERROR msg => + error ("Failed to resolve local AutoLocality named simproc " + ^ quote alias ^ " for " + ^ describe_locality_dispatch_key dispatch_key + ^ ":\n" ^ msg) + in + LocalityDispatcherInventory.map + (insert_locality_dispatcher_alias + dispatch_key origin source_name alias) context + end - fun arglist num idx x = - make_arglist num - |> list_set_nth idx x - |> String.concatWith " " + fun ensure_locality_dispatcher dispatch_key lthy = + let + val current_context = Context.Proof lthy + val target_context = + Context.Proof (Local_Theory.target_of lthy) + val current_entry = + locality_dispatcher_entry current_context dispatch_key + val target_entry = + locality_dispatcher_entry target_context dispatch_key + in + case (target_entry, current_entry) of + (SOME _, SOME _) => + let + val _ = + AutoLocality_Instrumentation.record_counters lthy (fn () => + [(AutoLocality_Instrumentation.Lifecycle_Duplicate_Dispatchers, + 1)]) + in + lthy + end + | (NONE, SOME _) => + error ("AutoLocality dispatcher for " + ^ describe_locality_dispatch_key dispatch_key + ^ " is visible only in a temporary local context; " + ^ "register it in its owning local theory") + | (SOME _, NONE) => + error ("AutoLocality target dispatcher is absent from the " + ^ "current local theory for " + ^ describe_locality_dispatch_key dispatch_key) + | (NONE, NONE) => + let + val binding = locality_simproc_binding dispatch_key + val origin = stamp () + val source_name = + Local_Theory.full_name lthy binding + val identifier = + locality_dispatch_witness lthy dispatch_key + val (_, lthy') = + Simplifier.define_simproc + (locality_simproc_spec + lthy dispatch_key identifier) lthy + val lthy'' = + lthy' + |> Local_Theory.declaration + {pervasive = false, syntax = false, + pos = Binding.pos_of binding} + (replay_locality_dispatcher_name + dispatch_key origin source_name binding) + val _ = + if locality_dispatcher_declared + (Context.Proof lthy'') dispatch_key + andalso locality_dispatcher_declared + (Context.Proof + (Local_Theory.target_of lthy'')) dispatch_key + then () + else + error ("Failed to declare local AutoLocality dispatcher for " + ^ describe_locality_dispatch_key dispatch_key) + val _ = + AutoLocality_Instrumentation.record_counters lthy'' + (fn () => + [(AutoLocality_Instrumentation.Lifecycle_Dispatcher_Insertions, + 1)]) + in + lthy'' + end + end - fun make_locality_simproc_pattern attr_name num_args idx = - attr_name ^ " " ^ arglist num_args idx "(f X)" + fun replay_locality_registration rec_name descriptor facts0 phi context = + let + val ctxt = Context.proof_of context + val entry = + morph_locality_entry_bundle context phi descriptor facts0 + in + add_record_locality_entry_generic ctxt rec_name entry context + end - fun make_locality_simproc ctxt rec_name attr_name num_args idx : simproc = + \\Declare a complete typed registration. Attribute families receive one + ordinary local named simproc declaration. Its generic callback consults the + separately declared, morphism-aware semantic registry at invocation time. + A small local name inventory supports explicit reactivation after + \<^verbatim>\simp only:\; it does not own theorem payloads or require background-theory + installation.\ + fun add_record_locality_entry ctxt (rec_name : string) + (entry : locality_entry) lthy = let - val _ = Pretty.text ("Creating simproc for attribute " ^ attr_name ^ " on record " ^ rec_name) - |> Pretty.block |> locality_pretty_trace ctxt 0 - val simproc_name = (register_locality_attr_simproc_name rec_name attr_name idx) - val ptrn_str = make_locality_simproc_pattern attr_name num_args idx - val ptrn = Syntax.read_term ctxt ptrn_str + val _ = locality_pretty_trace ctxt 1 (fn () => + [Pretty.str "add_record_locality_entry", Pretty.brk 1, + Syntax.pretty_term ctxt (#pattern entry), Pretty.brk 1, + Pretty.list "[" "]" (List.map Pretty.str (#footprint entry))] + |> Pretty.block) + val descriptor = locality_entry_descriptor entry + val facts0 = locality_entry_fact_bundle lthy entry + val dispatch_key = + if locality_entry_kind entry = Locality_Attribute + then locality_dispatch_key_of_entry_opt ctxt entry + else NONE + val lthy' = + (case dispatch_key of + NONE => lthy + | SOME key => ensure_locality_dispatcher key lthy) + fun declare_registration lthy' = + Local_Theory.declaration + {pervasive = false, syntax = false, pos = Position.none} + (replay_locality_registration + rec_name descriptor facts0) + lthy' in - Simplifier.make_simproc ctxt {name = simproc_name, kind = Simproc, identifier = [], - lhss = [ptrn], proc = K (locality_cancellation_simproc rec_name attr_name idx) } + declare_registration lthy' end \\End of the simproc code\ @@ -781,13 +4499,21 @@ ML\ let (* Lookup fields from record *) val (rec_ty, rec_name) = prepare_rec_name ctxt rec_name - val (_, _, ctxt) = check_create_named_theorems (default_named_theorems_for_record rec_name) ctxt - val fields = get_fields rec_name ctxt + val field_selectors_full = locality_field_selector_names ctxt rec_name + val fields = map Long_Name.base_name field_selectors_full + val field_updates_full = get_field_updates_full rec_name ctxt + fun field_selector_for field = + locality_field_name_lookup "field" field_selectors_full field + fun field_update_for field = + case List.find (fn name => dest_field_update name = SOME field) + field_updates_full of + SOME name => name + | NONE => error ("Unknown record field update " ^ quote field) (* Checks if a string is a field in the given record *) - fun is_field (f0 : string) : bool = List.exists (fn f1 => f0 = f1) fields + fun check_field (f0 : string) : bool = List.exists (fn f1 => f0 = f1) fields (* Check that the footprint is a list of fields *) - val footprint_ok = List.all is_field footprint + val footprint_ok = List.all check_field footprint (* Lookup disjoint fields -- we'll need one orthogonality lemma for each of them *) val disjoint_fields = List.filter (fn f0 => List.all (fn f1 => f0 <> f1) footprint) fields @@ -803,112 +4529,180 @@ ML\ (* Get rid of positioning information that's inherent in p_name and rec_name since they are produced by Parse.typ and Parse.term, respectively. Otherwise, the proposition-strings built below won't be recognized. *) - val p_name = Syntax.read_input p_name |> Input.string_of + val p_name = p_term |> extract_const val rec_name = Syntax.read_input rec_name |> Input.string_of + + val is_field = member (op =) field_updates_full p_name + (* Check that the given term is indeed a function on the given record *) val (_, num_args, rec_namex) = dest_fun_term ctxt rec_ty p_term |> Option.valOf - val p_id = string_to_identifier p_name + (* Identifier used for the generated fact names. For a bare constant this is just its base + name (keeping the common-case names stable). For a PARTIAL APPLICATION - e.g. + 'w_apply_policy policy_a' - the baked-in argument is what + distinguishes one locality_lemma from another with the same head constant, so it must enter + the name: deriving p_id from the head alone makes the two collide (duplicate fact). We + therefore fold the applied arguments into the identifier via the pretty-printed term. *) + (* A PARTIAL APPLICATION is the operator applied to one or more CONSTANT arguments — e.g. + 'w_apply_policy policy_a'. We must distinguish these from + LOCALE PARAMETERS, which 'Syntax.read_term' also applies to the bare constant but as fixed + 'Free's (e.g. inside locale 'scaler', 'bumpval' reads as 'scaler.bumpval $ Free bump'). Only + the Const-headed arguments count: they are what the baked-in operator must carry. Locale + parameters are left to the ordinary 'make_arglist'/'num_args' machinery (which fills the + remaining argument positions), so the locale case keeps the original behaviour. *) + val baked_cnames = snd (Term.strip_comb p_term) |> map_filter (fn t => + case Term.head_of t of Const (c, _) => SOME c | _ => NONE) + + (* Identifier used for the generated fact names. For a bare constant (or one applied only to + locale parameters) this is its base name, keeping the common-case names stable; for a genuine + partial application the baked-in constant must enter the name, or two locality_lemmas with the + same head constant collide (duplicate fact). *) + val p_id = locality_public_id ctxt p_term + val _ = + assert_locality_public_id_available ctxt rec_name + Locality_Operation rec_namex p_id p_term + + (* The operator string used to BUILD the lemma statements: the pretty-printed term itself, + wrapped in parens for safe re-parsing. This is correct in all three cases: a bare constant + prints as its (short, re-parseable) name; a genuine partial application keeps its baked + argument ('(w_apply_policy policy_a)') rather than abstracting it into a fresh variable; and + a locale operation prints with its parameter in the short form that re-parses with the + parameter re-applied (the fully-qualified head 'p_name' would NOT re-apply it, causing a + type clash). *) + val p_op_str = "(" ^ (Syntax.pretty_term ctxt p_term |> Pretty.pure_string_of) ^ ")" + + (* Constants to unfold when discharging: the operation, the constants baked into a partial + application, and the user-defined helpers/operations the body delegates to. *) + val discharge_cnames = + (p_name :: baked_cnames + @ locality_body_helpers_to_unfold ctxt rec_name p_name) + |> distinct (op =) fun arglist_with x = make_arglist num_args |> list_set_nth rec_namex x |> String.concatWith " " val argsA = arglist_with "R" - fun argsB field = arglist_with ("(" ^ field_update rec_name field ^ " f R)") + fun argsB field = + arglist_with ("(" ^ field_update_for field ^ " f R)") (* Build statements of locality lemmas *) fun commutativity_str (prop : string) (field : string) = "\f " ^ argsA ^ " . " ^ prop ^ " " ^ argsB field ^ " = " ^ - (field_update rec_name field) ^ " f (" ^ prop ^ " " ^ argsA ^ ")" + field_update_for field ^ " f (" ^ prop ^ " " ^ argsA ^ ")" fun get_commutativity_stm prop field = commutativity_str prop field |> Syntax.read_prop ctxt - val commutativity_stms = List.map (get_commutativity_stm p_name) disjoint_fields + val commutativity_stms = List.map (get_commutativity_stm p_op_str) disjoint_fields (* Build statements of disjointness lemmas *) fun disjoint_str (prop : string) (field : string) = - let val field_proj = rec_name ^ "." ^ field in + let val field_proj = field_selector_for field in "\f " ^ argsA ^ ". " ^ field_proj ^ " (" ^ prop ^ " " ^ argsA ^ ") = " ^ field_proj ^ " R" end fun get_disjoint_stm prop field = disjoint_str prop field |> Syntax.read_prop ctxt - val disjoint_stms = List.map (get_disjoint_stm p_name) disjoint_fields + val disjoint_stms = List.map (get_disjoint_stm p_op_str) disjoint_fields - fun make_iterated_field_update rec_name fields_with_vals arg = - fold (fn (f,v) => fn s => (field_update rec_name f) ^ " (\_. " ^ v ^ ") (" ^ s ^ ")") + fun make_iterated_field_update fields_with_vals arg = + fold (fn (f,v) => fn s => field_update_for f ^ " (\_. " ^ v ^ ") (" ^ s ^ ")") fields_with_vals ("(" ^ arg ^ ")") - fun field_proj field = rec_name ^ "." ^ field + fun field_proj field = field_selector_for field + \\Build a no-op telescope of field updates: each field is rewritten to its own current + projection, so the telescoped record is provably equal to the original. Used by the + disjointness proof to introduce the disjoint fields under a no-op update before pushing + them past the operation via commutativity.\ fun make_noop_iterated_field_update fields arg = - let - val fields_with_vals = List.map (fn f => (f, field_proj f ^ " (" ^ arg ^ ")")) fields - in - make_iterated_field_update rec_name fields_with_vals arg - end + let val fields_with_vals = List.map (fn f => (f, field_proj f ^ " (" ^ arg ^ ")")) fields + in make_iterated_field_update fields_with_vals arg end (* Build statements of 'local action' lemmas *) fun local_action_str (prop : string) = let fun new_field_val f = field_proj f ^ "( " ^ prop ^ " " ^ argsA ^ ")" val footprint_with_vals = List.map (fn f => (f, new_field_val f)) footprint - val field_updates = make_iterated_field_update rec_name footprint_with_vals "R" + val field_updates = make_iterated_field_update footprint_with_vals "R" in "\f " ^ argsA ^ ". " ^ prop ^ " " ^ argsA ^ " = " ^ field_updates end - val local_action_stm = local_action_str p_name |> Syntax.read_prop ctxt + val local_action_stm = local_action_str p_op_str |> Syntax.read_prop ctxt val commutativity_thm_name = register_locality_op_commutativity_thm_name rec_name p_id val disjointness_thm_name = register_locality_op_disjointness_thm_name rec_name p_id val local_action_thm_name = register_locality_op_local_action_thm_name rec_name p_id + val flexible_prefix = locality_pattern_flexible_prefix p_term + val replay = + locality_registration_is_replay ctxt rec_name p_name p_term + flexible_prefix Locality_Operation + footprint num_args rec_namex is_field + (length disjoint_fields) (length disjoint_fields) true fun after_qed (apply_attribs : bool) (named_thm_list_opt) name (cont : Proof.context -> Proof.context) thms ctxt = let val thms = thms |> flat - val _ = "after_qed3" |> tracing val attribs = unpack_attributes_default ctxt rec_name attribs_opt |> List.map (Attrib.check_src ctxt) + val default_attribs = not (Option.isSome attribs_opt) + val public_attribs = + if apply_attribs andalso default_attribs then attribs else [] + val note_explicit_attribs = + apply_attribs andalso not default_attribs in ctxt |> (case named_thm_list_opt of SOME n => fold (fn t => Local_Theory.declaration {pervasive=false, syntax=false, pos=Position.none} (fn _ => Named_Theorems.add_thm n t)) thms | NONE => I) - |> Local_Theory.note (((Binding.name name), []), thms) |> snd - |> (if apply_attribs then + |> Local_Theory.note + (((Binding.name name), public_attribs), thms) |> snd + |> (if note_explicit_attribs then (Local_Theory.note ((Binding.empty,attribs), thms) #> snd) else I) |> cont end + \\The core (commutativity-with-disjoint-field-updates) lemmas remain interactive, so the + user can supply a manual proof for awkward operations. The automatic attempt is the old + method-string \<^verbatim>\auto simp add: Let_def <_locality_facts>\, which is a single \<^verbatim>\auto\ + call against the ambient simpset. Switching to an ML-built simpset regressed this badly: + the ML approach constructs an ambient+\<^verbatim>\record_simps\+facts simpset eagerly per phase per + field-update during \<^verbatim>\locality_init\ (~1.8s for 21 constructions on a wide record), even when + the goal closes by trivial rewriting; the method-string form lets the simplifier reuse the + already-indexed ambient net.\ val default_simps = - let val found_def = is_const_with_def ctxt p_name - val const_unfold = if found_def then [Thm.def_name p_name] else [] - val _ = if not found_def then - Pretty.text "Could not find definitional theorem for:" @ [Pretty.brk 1, Pretty.str p_name] - |> Pretty.block |> locality_pretty_trace ctxt 1 else () + let val const_unfold = + discharge_cnames |> map_filter (locality_def_fact_name ctxt) val locality_facts = if Option.isSome attribs_opt then [] else [default_named_theorems_for_record rec_name] val all_simps = ["Let_def"] @ const_unfold @ locality_facts in String.concatWith " " all_simps end - - val (named_thms, ctxt') = check_create_commutativity_theorems rec_name ctxt + val default_splits = String.concatWith " " (locality_body_case_split_names ctxt discharge_cnames) fun start_core_proof ctxt cont = ctxt - |> Proof.theorem NONE (after_qed true (SOME named_thms) commutativity_thm_name cont) [map (fn t => (t,[])) commutativity_stms] + |> Proof.theorem NONE (after_qed (not is_field) NONE commutativity_thm_name cont) [map (fn t => (t,[])) commutativity_stms] |> apply_method (SIMPLE_METHOD all_tac) |> (if with_proof then - apply_txt ctxt ("(auto simp add: " ^ default_simps ^ ")?") + apply_txt ctxt ("(auto simp add: " ^ default_simps ^ " split: " ^ default_splits ^ ")?") else I) + \\The 'local action' lemma is fully automatic. The old method-string discharge is + \<^verbatim>\auto intro: .expand simp add: \: extensionality reduces to per-field + equalities which the disjointness lemma normalises. We re-enter an interactive proof and + globally close it, which keeps the proof shape uniform with \<^verbatim>\derive_disjointness\ and avoids + the eager ML simpset construction that the WIP rewrite paid per op.\ fun derive_locality cont ctxt = - let val _ = - [Pretty.str "Autoderive locality theorem: ", - Syntax.pretty_term ctxt local_action_stm] - |> Pretty.breaks |> Pretty.block |> locality_pretty_trace ctxt 0 in + let + val expand_thm_name = + locality_record_expand_thm_name ctxt rec_name + val _ = locality_pretty_trace ctxt 0 (fn () => + [Pretty.str "Autoderive locality theorem: ", + Syntax.pretty_term ctxt local_action_stm] + |> Pretty.breaks |> Pretty.block) in ( ctxt |> Proof.theorem NONE (after_qed false NONE local_action_thm_name cont) [map (fn t => (t,[])) [local_action_stm]] |> apply_method (SIMPLE_METHOD all_tac) - |> apply_txt ctxt ("(auto intro: " ^ rec_name ^ ".expand simp add: " ^ disjointness_thm_name ^ ")") + |> apply_txt ctxt ("(auto intro: " ^ expand_thm_name + ^ " simp add: " ^ disjointness_thm_name ^ ")") |> Proof.global_done_proof) handle ERROR _ => ([Pretty.str "Something went wrong proving locality theorem: ", @@ -916,9 +4710,15 @@ ML\ |> Pretty.breaks |> Pretty.block |> Pretty.string_of |> warning; ctxt) end + \\The disjointness lemmas (field projections not in the footprint are unaffected by the + operation) are proved by the old \<^verbatim>\subgoal_tac\+\<^verbatim>\simp\+\<^verbatim>\subst commutativity\ trick: rewrite + the operation to a record where the disjoint field has been refreshed by a no-op update, + then push that update past the operation via the freshly-proved commutativity lemma, and + simplify. As with the core proof we use the method-string form to avoid eager ML simpset + construction.\ fun derive_disjointness cont ctxt = - let val subgoal = p_name ^ " " ^ argsA ^ " = " ^ - p_name ^ " " ^ arglist_with ("(" ^ make_noop_iterated_field_update disjoint_fields "R" ^ ")") + let val subgoal = p_op_str ^ " " ^ argsA ^ " = " ^ + p_op_str ^ " " ^ arglist_with ("(" ^ make_noop_iterated_field_update disjoint_fields "R" ^ ")") in ( ctxt |> Proof.theorem NONE (after_qed true NONE disjointness_thm_name cont) [map (fn t => (t,[])) disjoint_stms] @@ -936,17 +4736,42 @@ ML\ |> Pretty.chunks |> Pretty.string_of |> warning; ctxt) end + fun wrapup ctxt = + let + val local_thms = Proof_Context.get_thms ctxt local_action_thm_name + val local_thm = + (case local_thms of + [thm] => SOME thm + | _ => error ("Expected one local-action theorem for " ^ p_name)) + val entry : locality_entry = + make_locality_entry rec_name Locality_Operation + p_name p_term flexible_prefix footprint num_args rec_namex + is_field + (Proof_Context.get_thms ctxt commutativity_thm_name) + (Proof_Context.get_thms ctxt disjointness_thm_name) + local_thm + in + add_record_locality_entry ctxt rec_name entry ctxt + end in - start_core_proof ctxt' (derive_disjointness (derive_locality - (add_record_locality_entry ctxt' rec_name "operation" p_name footprint num_args rec_namex NONE))) + if replay then + locality_registration_replay_proof ctxt + else + let + val (_, _, ctxt') = + check_create_named_theorems + (default_named_theorems_for_record rec_name) ctxt + in + start_core_proof ctxt' + (derive_disjointness (derive_locality wrapup)) + end end - fun state_locality_for_attribute attribs_opt (rec_name : string) (p_name: string) + fun state_locality_for_attribute attribs_opt (rec_name : string) (p_term: term) (footprint: string list) (with_proof : bool) (rec_namex : int) (ctxt : Proof.context) = - let + let (* Lookup fields from record *) val (rec_ty, rec_name) = prepare_rec_name ctxt rec_name - val (_, _, ctxt) = check_create_named_theorems (default_named_theorems_for_record rec_name) ctxt val fields = get_fields rec_name ctxt val strlist_to_str = String.concatWith ", " @@ -966,79 +4791,332 @@ ML\ ^ fieldlist_to_str fields |> error) else ()) - val p_term = Syntax.read_term ctxt p_name - (* Get rid of positioning information that's inherent in p_name and rec_name since they - are produced by Parse.typ and Parse.term, respectively. Otherwise, the proposition-strings - built below won't be recognized. *) - val p_name = Syntax.read_input p_name |> Input.string_of - (* Check that the given term is indeed a function on the given record *) - val (_, num_args, rec_namexs) = dest_attr_term ctxt rec_ty p_term |> Option.valOf - val p_id = string_to_identifier p_name + (* Use the passed-in term directly - don't re-parse! + This preserves locale parameter applications. *) + val p_name = p_term |> extract_const + val (_, num_args, rec_namexs) = dest_attr_term ctxt rec_ty p_term |> Option.valOf + (* Identifier used for the generated fact names. As on the operation path, a bare constant + uses its base name (stable common-case names), but a PARTIAL APPLICATION must fold the + applied argument into the name — otherwise two attributes that are different partial + applications of one head constant (or an abbreviation aliasing another attribute) collide on + the generated cancellation fact/list name. *) + val p_id = locality_public_id ctxt p_term val _ = if not (Library.member (op =) rec_namexs rec_namex) then error ("Illegal argument index " ^ (rec_namex |> Int.toString) ^ - " passed to state_locality_for_attribute") + " passed to state_locality_for_attribute, valid indices are " ^ + (rec_namexs |> List.map Int.toString |> String.concatWith ", ")) else () - - fun arglist_with x = - make_arglist num_args - |> list_set_nth rec_namex x - |> String.concatWith " " - val argsA = arglist_with "R" - fun argsB field = arglist_with ("(" ^ field_update rec_name field ^ " f R)") - - (* Build statements of locality lemmas *) - fun commutativity_str (prop : string) (field : string) = - "\f " ^ argsA ^ ". " ^ prop ^ " " ^ argsB field ^ " = " ^ prop ^ " " ^ argsA - fun get_commutativity_stm prop field = commutativity_str prop field |> Syntax.read_prop ctxt - val commutativity_stms = List.map (get_commutativity_stm p_name) disjoint_fields + val _ = + assert_locality_public_id_available ctxt rec_name + Locality_Attribute rec_namex p_id p_term + + (* Build proposition terms directly to preserve locale parameter applications. + Keep p_term itself as the public registration pattern, but specialize a + freshened copy of its type scheme at the selected record argument. + Polymorphic constants parsed in a theory context contain fixed TFrees; + applying that raw term to rec_ty-valued arguments would mix two + independent type-variable coordinate systems. *) + val certificate_term = + let + val fresh_inc = Term.maxidx_of_typ rec_ty + 1 + val term_scheme = + p_term + |> locality_varify_types_preserving + (locality_assumption_tfrees ctxt) + |> Term.map_types (Logic.incr_tvar fresh_inc) + in + term_scheme + end + val certificate_rec_ty = + nth (Term.binder_types (Term.type_of certificate_term)) rec_namex + + (* Create free variable for the record *) + val R_var = Free ("R", certificate_rec_ty) + + (* Get the argument types from the specialized certificate term. *) + val p_ty = Term.type_of certificate_term + val arg_tys = Term.binder_types p_ty |> Library.take num_args + val p_result_ty = Term.body_type p_ty + + (* Create free variables for all arguments *) + val arg_vars = arg_tys |> Library.map_index (fn (i, ty) => + if i = rec_namex then R_var else Free ("arg" ^ Int.toString i, ty)) + + (* Build the update term for a field: update_field f R + where f has the appropriate field update type *) + fun mk_update_term field = + let + val upd_name = locality_field_update_name ctxt rec_name field + val sel_name = locality_field_selector_name ctxt rec_name field + val thy = Proof_Context.theory_of ctxt + val fresh_inc = Term.maxidx_of_term certificate_term + 1 + fun read_fresh_const name = + let + val t = Syntax.read_term ctxt name + in + (extract_const t, + Term.type_of t + |> locality_varify_typ + |> Logic.incr_tvar fresh_inc) + end + val (_, sel_ty) = read_fresh_const sel_name + val sel_match = + Sign.typ_match thy + (Term.domain_type sel_ty, certificate_rec_ty) Vartab.empty + handle Type.TYPE_MATCH => + error ("Cannot instantiate field selector " ^ sel_name + ^ " from " ^ Syntax.string_of_typ ctxt sel_ty + ^ " at record type " + ^ Syntax.string_of_typ ctxt certificate_rec_ty + ^ "\nInternal selector type: " ^ ML_Syntax.print_typ sel_ty + ^ "\nInternal record type: " + ^ ML_Syntax.print_typ certificate_rec_ty) + val field_ty = + Envir.subst_type sel_match (Term.range_type sel_ty) + val (upd_const_name, upd_ty) = read_fresh_const upd_name + val upd_arg_tys = Term.binder_types upd_ty + val upd_field_fun_ty = nth upd_arg_tys 0 + val upd_record_input_ty = nth upd_arg_tys 1 + (* Constrain the updated field and the input record, but leave type + parameters occurring only in the output record schematic. A + datatype-record updater may change such phantom parameters even + when the field update itself is endomorphic. *) + val upd_input_match = + Sign.typ_match thy + (upd_record_input_ty, certificate_rec_ty) Vartab.empty + handle Type.TYPE_MATCH => + error ("Cannot instantiate field updater " ^ upd_name + ^ " input from " ^ Syntax.string_of_typ ctxt upd_ty + ^ " at record type " + ^ Syntax.string_of_typ ctxt certificate_rec_ty + ^ "\nInternal updater type: " ^ ML_Syntax.print_typ upd_ty + ^ "\nInternal record type: " + ^ ML_Syntax.print_typ certificate_rec_ty) + val upd_match = + Sign.typ_match thy + (upd_field_fun_ty, field_ty --> field_ty) upd_input_match + handle Type.TYPE_MATCH => + error ("Cannot instantiate field updater " ^ upd_name + ^ " function from " ^ Syntax.string_of_typ ctxt upd_ty + ^ " at field type " ^ Syntax.string_of_typ ctxt field_ty + ^ "\nInternal updater type: " ^ ML_Syntax.print_typ upd_ty + ^ "\nInternal field type: " ^ ML_Syntax.print_typ field_ty) + val upd_const = + Const (upd_const_name, Envir.subst_type upd_match upd_ty) + val f_var = Free ("f", field_ty --> field_ty) + in (f_var, upd_const $ f_var $ R_var) end + + (* Apply the certificate term to arguments, substituting rec_arg for the + record position. Freshen and specialize the attribute separately for + each side: the updater output may differ from its input only in + phantom record parameters, while all non-record arguments and the + result type remain shared by the equality. *) + fun apply_p_term_to rec_arg = + let + val thy = Proof_Context.theory_of ctxt + val target_arg_tys = + arg_vars |> map_index (fn (i, v) => + if i = rec_namex then Term.type_of rec_arg else Term.type_of v) + val target_ty = + fold_rev (fn arg_ty => fn result_ty => arg_ty --> result_ty) + target_arg_tys p_result_ty + val target_maxidx = + fold (fn T => fn i => Int.max (Term.maxidx_of_typ T, i)) + (target_ty :: map Term.type_of arg_vars) ~1 + val term_scheme = + certificate_term + |> Term.map_types (Logic.incr_tvar (target_maxidx + 1)) + val tyenv = + Sign.typ_match thy + (Term.type_of term_scheme, target_ty) Vartab.empty + handle Type.TYPE_MATCH => + error ("Cannot specialize attribute " + ^ Syntax.string_of_term ctxt p_term + ^ " at record type " + ^ Syntax.string_of_typ ctxt (Term.type_of rec_arg)) + val specialized_term = Envir.subst_term_types tyenv term_scheme + val args = arg_vars |> map_index (fn (i, v) => + if i = rec_namex then rec_arg else v) + in + Term.list_comb (specialized_term, args) + end + + (* Build commutativity statement: \f R args. p_term (update f R) args = p_term R args *) + fun mk_commutativity_stm field = + let val (f_var, update_term) = mk_update_term field + val lhs = apply_p_term_to update_term + val rhs = apply_p_term_to R_var + val eq = HOLogic.mk_eq (lhs, rhs) + val prop = HOLogic.mk_Trueprop eq + (* Quantify over f, R, and all other argument variables *) + val other_args = arg_vars |> List.filter (fn v => v <> R_var) + in fold_rev Logic.all (other_args @ [R_var, f_var]) prop end + + val commutativity_stms = List.map mk_commutativity_stm disjoint_fields fun after_qed (named_thm_list_opt) name (cont : Proof.context -> Proof.context) thms ctxt = let val thms = thms |> flat val attribs = unpack_attributes_default ctxt rec_name attribs_opt |> List.map (Attrib.check_src ctxt) + val default_attribs = not (Option.isSome attribs_opt) + val public_attribs = if default_attribs then attribs else [] in ctxt |> (case named_thm_list_opt of SOME n => fold (fn t => Local_Theory.declaration {pervasive=false, syntax=false, pos=Position.none} (Named_Theorems.add_thm n t |> K)) thms | NONE => I) - |> Local_Theory.note (((Binding.name name), []), thms) |> snd - |> Local_Theory.note ((Binding.empty,attribs), thms) |> snd + |> Local_Theory.note + (((Binding.name name), public_attribs), thms) |> snd + |> (if default_attribs then I + else Local_Theory.note ((Binding.empty,attribs), thms) #> snd) |> cont end + \\As for operations, the cancellation lemmas remain interactive, so the user can supply a + manual proof. The automatic attempt is the old method-string \<^verbatim>\auto simp add: Let_def + <_locality_facts>\: handing the rules to \<^verbatim>\auto\ by name lets the simplifier reuse the + ambient indexed simpset, whereas the WIP rewrite's ML-built simpset paid for ambient + construction eagerly per-call.\ + (* As on the operation path: unfold the attribute and the user-defined helpers its body + delegates to, so case/let/delegation attribute bodies normalise. *) + val attr_discharge_cnames = + (p_name :: locality_body_helpers_to_unfold ctxt rec_name p_name) + |> distinct (op =) val default_simps = - let val const_unfold = if is_const_with_def ctxt p_name then [Thm.def_name p_name] else [] + let val const_unfold = + attr_discharge_cnames |> map_filter (locality_def_fact_name ctxt) val locality_facts = if Option.isSome attribs_opt then [] else [default_named_theorems_for_record rec_name] val all_simps = ["Let_def"] @ const_unfold @ locality_facts in String.concatWith " " all_simps end + val default_splits = String.concatWith " " (locality_body_case_split_names ctxt attr_discharge_cnames) val cancellation_thm_name = register_locality_attr_cancellation_thm_name rec_name p_id rec_namex val cancellation_thms_name = register_locality_attr_cancellation_thm_list_name rec_name p_id rec_namex + val flexible_prefix = locality_pattern_flexible_prefix p_term + val replay = + locality_registration_is_replay ctxt rec_name p_name p_term + flexible_prefix Locality_Attribute + footprint num_args rec_namex false + (length disjoint_fields) 0 false + + fun wrapup ctxt = + let + val entry : locality_entry = + make_locality_entry rec_name Locality_Attribute + p_name p_term flexible_prefix footprint num_args rec_namex + false (Proof_Context.get_thms ctxt cancellation_thm_name) + [] NONE + in + add_record_locality_entry ctxt rec_name entry ctxt + end + in + if replay then + locality_registration_replay_proof ctxt + else + let + val (_, _, ctxt0) = + check_create_named_theorems + (default_named_theorems_for_record rec_name) ctxt + val (cancellation_thms_name, ctxt') = + ctxt0 + |> Named_Theorems.declare + (Binding.make (cancellation_thms_name, \<^here>)) "" + fun start_core_proof ctxt cont = ctxt + |> Proof.theorem NONE + (after_qed (SOME cancellation_thms_name) + cancellation_thm_name cont) + [map (fn t => (t, [])) commutativity_stms] + |> apply_method (SIMPLE_METHOD all_tac) + |> (if with_proof then + apply_txt ctxt + ("(auto simp add: " ^ default_simps + ^ " split: " ^ default_splits ^ ")?") + else + I) + in + start_core_proof ctxt' wrapup + end + end - val (cancellation_thms_name, ctxt') = ctxt - |> Named_Theorems.declare (Binding.make (cancellation_thms_name, \<^here>)) "" - - fun start_core_proof ctxt cont = ctxt - |> Proof.theorem NONE (after_qed (SOME cancellation_thms_name) cancellation_thm_name cont) [map (fn t => (t,[])) commutativity_stms] - |> apply_method (SIMPLE_METHOD all_tac) - |> (if with_proof then - apply_txt ctxt ("(auto simp add: " ^ default_simps ^ ")?") - else - I) + fun register_locality_field (rec_name: string) (field: string, update: string) + (ctxt: Proof.context) = + let + val count = locality_direct_counter ctxt + val _ = locality_count_int count + AutoLocality_Instrumentation.Lifecycle_Registration_Attempts + (fn () => 2) + val (rec_ty, rec_name) = prepare_rec_name ctxt rec_name + val field_short = field |> Long_Name.base_name + val _ = locality_pretty_trace ctxt 1 (fn () => + Pretty.text ("Registering locality data for field " ^ field_short + ^ " (full name: " ^ field + ^ ") on record") @ [Pretty.brk 1, Syntax.pretty_typ ctxt rec_ty] + |> Pretty.block) + val field_entry : locality_entry = + make_locality_entry rec_name Locality_Attribute + field (Syntax.read_term ctxt field) [] [field_short] + 1 0 true [] [] NONE + val update_entry : locality_entry = + make_locality_entry rec_name Locality_Operation + update (Syntax.read_term ctxt update) [] [field_short] + 2 1 true [] [] NONE in - start_core_proof ctxt' (add_record_locality_entry ctxt' rec_name "attribute" - p_name footprint num_args rec_namex - (SOME (make_locality_simproc ctxt' rec_name p_name num_args rec_namex))) + ctxt + |> add_record_locality_entry ctxt rec_name field_entry + |> add_record_locality_entry ctxt rec_name update_entry end + fun locality_init_for (rec_name : string) (log: bool) (ctxt : Proof.context) : Proof.context = + let val (_, rec_name) = prepare_rec_name ctxt rec_name + in + if has_record_locality_data_for_record rec_name ctxt then + ((if log then + locality_pretty_trace ctxt 1 (fn () => + Pretty.text ("Record " ^ rec_name ^ " already initialized") + |> Pretty.block) + else ()); + ctxt) + else let + val _ = locality_pretty_trace ctxt 1 (fn () => + Pretty.text ("Initializing locality data for record " ^ rec_name) + |> Pretty.block) + val fields = get_fields_full rec_name ctxt + |> List.map (Syntax.read_input #> Input.string_of) + |> List.map (Syntax.parse_term ctxt) |> List.map extract_const + + val field_updates_full = get_field_updates_full rec_name ctxt + \\Always declare the record's \<^verbatim>\_locality_facts\ named-theorems bundle, even though we are not + populating it eagerly. Downstream theories reference the name (e.g. \<^verbatim>\simp add: \_locality_facts\), + so the bundle must exist after \<^verbatim>\locality_init\; the bundle is then filled by subsequent + \<^verbatim>\locality_lemma\ commands.\ + val (_, _, ctxt) = check_create_named_theorems (default_named_theorems_for_record rec_name) ctxt + in + ctxt |> fold (register_locality_field rec_name) (fields ~~ field_updates_full) + end end + + val record_init_argparse = ((Args.$$$ "for") |-- Parse.typ) + + val _ = Outer_Syntax.local_theory @{command_keyword "locality_init"} + "prove locality lemma for operations and attributes on records" + (record_init_argparse >> (fn rec_name => + locality_init_for rec_name true + )) + fun state_locality attribs_opt (rec_name : string) (p_name: string) (footprint: string list) (with_proof : bool) (match_idx : int) (ctxt : Proof.context) = let val (rec_ty, rec_name) = prepare_rec_name ctxt rec_name val p_term = Syntax.read_term ctxt p_name + (* Dispatch on the type of the (possibly partially applied) term. For an operation we forward + the ORIGINAL term string 'p_name' — NOT the bare head constant — so that a partial + application like 'w_apply_policy policy_a' keeps its baked + argument; stripping to the head const here is what made the generated statement abstract the + argument into a fresh variable and become unprovable. The attribute branch already forwards + the full 'p_term'. *) val p_ty = Term.type_of p_term + val ctxt = locality_init_for rec_name false ctxt in if is_fun_ty_on rec_ty p_ty then state_locality_for_op attribs_opt rec_name p_name footprint with_proof ctxt @@ -1049,17 +5127,20 @@ ML\ @ [Pretty.brk 1, Syntax.pretty_typ ctxt rec_ty] |> Pretty.block |> Pretty.string_of |> Exn.error | SOME (_, _, idxs) => - ([Pretty.str "Indices:", Pretty.list "[" "]" (List.map (Int.toString #> Pretty.str) idxs), - Pretty.str "Index", Pretty.str (match_idx |> Int.toString)] - |> Pretty.breaks |> Pretty.block |> locality_pretty_trace ctxt 1; - state_locality_for_attribute attribs_opt rec_name p_name footprint with_proof + (locality_pretty_trace ctxt 1 (fn () => + [Pretty.str "Indices:", + Pretty.list "[" "]" (List.map (Int.toString #> Pretty.str) idxs), + Pretty.str "Index", Pretty.str (match_idx |> Int.toString)] + |> Pretty.breaks |> Pretty.block); + state_locality_for_attribute attribs_opt rec_name p_term footprint with_proof (nth idxs match_idx) ctxt) end val record_local_op_argparse = ((Args.$$$ "for") |-- Parse.typ) -- Scan.optional (Args.parens (Args.$$$ "no_proof") >> K true) false - -- (Scan.optional (Parse.attribs >> SOME) NONE --| Args.colon) + -- (Scan.optional (Parse.attribs >> SOME) NONE) + --| Args.colon -- Parse.term -- (Scan.optional ( Args.bracks Parse.int) 0) -- (Args.$$$ "footprint" |-- (Args.bracks (Parse.list Parse.short_ident))) @@ -1070,44 +5151,6 @@ ML\ (fn (((((rec_name, no_proof), attribs_opt), p_name), match_idx), field_list) => state_locality attribs_opt rec_name p_name field_list (not no_proof) match_idx)) - fun remove_todo attribs rec_name ({const_name = cA, const_type = typeA, footprint=_, idx=idxA, args=_, sp=_}, - {const_name = cB, const_type = typeB, footprint=_, idx=idxB, args=_, sp=_}) = - case (typeA, typeB) of - ("operation", "operation") => prove_commutativity_lemma_for_disjoint_operators attribs rec_name cA cB - | ("attribute", "operation") => prove_commutativity_lemma_for_disjoint_operator_and_attribute attribs rec_name cB cA idxA - | ("operation", "attribute") => prove_commutativity_lemma_for_disjoint_operator_and_attribute attribs rec_name cA cB idxB - | _ => "Invalid type combination (" ^ typeA ^ ", " ^ typeB ^ ") for commutativity proof" |> error - - fun locality_autoderive_core attribs_opt (rec_name : string) (ctxt : Proof.context) = - let - val (rec_ty, rec_name) = prepare_rec_name ctxt rec_name - val todo = find_disjoint_pairs_without_commutativity_lemma_generic rec_name (Context.Proof ctxt) - in - if length todo = 0 then - ((Pretty.text "Nothing to do for" @ [Pretty.brk 1, Syntax.pretty_typ ctxt rec_ty] - |> Pretty.block |> Pretty.string_of |> Output.information); ctxt) - else - ctxt - |> fold (remove_todo attribs_opt rec_name) todo - end - - fun locality_autoderive attribs_opt (rec_name_opt : string option) (ctxt : Proof.context) = - case rec_name_opt of - SOME rec_name => locality_autoderive_core attribs_opt rec_name ctxt - | NONE => (* Update all records for which at least one constant is registered *) - let val records = get_registered_records ctxt in - fold (locality_autoderive_core attribs_opt) records ctxt - end - - val locality_autoderive_argparse = - Scan.optional (((Args.$$$ "for") |-- Parse.typ) >> SOME) NONE - -- Scan.optional (Parse.attribs >> SOME) NONE - - val _ = Outer_Syntax.local_theory @{command_keyword "locality_autoderive"} - "autoderive locality lemmas for constants previously registered via locality_lemma" - (locality_autoderive_argparse >> - (fn (rec_name_opt, attribs_opt) => locality_autoderive attribs_opt rec_name_opt)) - val locality_check_argparse = Scan.optional (((Args.$$$ "for") |-- Parse.typ) >> SOME) NONE @@ -1137,21 +5180,18 @@ ML\ let val (rec_ty, rec_name) = prepare_rec_name ctxt rec_name fun has_info (c, _) = - has_record_locality_entry_generic rec_name (Long_Name.base_name c) (Context.Proof ctxt) + has_record_locality_entry_generic rec_name c (Context.Proof ctxt) val special_attributes = (* Field projections *) get_fields rec_name ctxt (* Various standard built-in attributes *) - @ List.map (fn t => t ^ "_" ^ rec_name) + @ List.map (fn t => t ^ "_" ^ (rec_name |> Long_Name.base_name)) [ "Rep", "case", "ctor_fold", "ctor_rec", "dtor", "rec", "size", "term_of"] fun is_builtin_attr (c, _) = Library.member (op =) special_attributes (Long_Name.base_name c) fun is_builtin_op (c, _) = - Library.member (op =) ( - (* Field updates *) - List.map (field_update rec_name) (get_fields rec_name ctxt) - ) (Long_Name.base_name c) + Library.member (op =) (get_field_updates_full rec_name ctxt) c val ops = list_operations_on_record rec_ty ctxt |> List.filter (not o is_builtin_op) val attrs = list_attributes_on_record rec_ty ctxt @@ -1199,22 +5239,182 @@ ML\ "print all locality data previously registerd via locality_lemma" (print_locality_data_argsparse >> print_locality_data) - fun locality_cancellation_simprocs_add_all ctxt : attribute = + fun locality_named_dispatchers ctxt = let - val attrs = get_attributes ctxt |> map snd - val attr_simprocs = attrs |> List.map (#sp #> Option.valOf) + fun resolve key name = + (name, Simplifier.the_simproc ctxt name + handle ERROR msg => + error ("Missing local AutoLocality named simproc " + ^ quote name ^ " for " + ^ describe_locality_dispatch_key key ^ ":\n" ^ msg)) + fun resolve_entry + (key, entry : locality_dispatcher_inventory_entry) = + let + val alias = #alias entry + val (_, simproc) = resolve key alias + in + (key, #source_name entry, alias, simproc) + end in - Thm.declaration_attribute (K (Raw_Simplifier.map_ss (fn ctxt => ctxt addsimprocs attr_simprocs))) + LocalityDispatcherInventory.get (Context.Proof ctxt) + |> LocalityDispatchKeyTable.dest + |> map resolve_entry end - fun locality_cancellation_simprocs_del_all ctxt : attribute = + fun locality_present_raw_dispatchers ctxt named_dispatchers = let - val attr_simprocs = get_attributes ctxt |> map snd |> List.map (#sp #> Option.valOf) + fun add_expected (key, source_name, _, _) expected = + Symtab.map_default (source_name, key) + (fn key' => + if locality_dispatch_key_eq (key, key') then key' + else + error ("AutoLocality source dispatcher name " + ^ quote source_name ^ " identifies both " + ^ describe_locality_dispatch_key key + ^ " and " + ^ describe_locality_dispatch_key key')) + expected + val expected = + fold add_expected named_dispatchers Symtab.empty + val raw_dispatchers = + Raw_Simplifier.simpset_of ctxt + |> Raw_Simplifier.dest_ss + |> #simprocs + fun observe (source_name, lhss) present = + (case Symtab.lookup expected source_name of + NONE => present + | SOME dispatch_key => + (case lhss of + [lhs] => + if locality_dispatch_key_eq + (locality_dispatch_key_of_trigger lhs, + dispatch_key) + then + Symtab.map_default (source_name, 0) + (fn count => count + 1) present + else + error ("Local AutoLocality dispatcher " + ^ quote source_name + ^ " has the wrong trigger family for " + ^ describe_locality_dispatch_key dispatch_key) + | _ => + error ("Local AutoLocality dispatcher " + ^ quote source_name + ^ " does not have exactly one trigger"))) + val present = + fold observe raw_dispatchers Symtab.empty + val _ = + Symtab.dest present + |> List.app (fn (source_name, count) => + if count = 1 then () + else + error ("Expected one local AutoLocality dispatcher " + ^ quote source_name ^ ", found " + ^ Int.toString count)) in - Thm.declaration_attribute (K (Raw_Simplifier.map_ss (fn ctxt => ctxt delsimprocs attr_simprocs))) - end\ + present + end -attribute_setup locality_cancel = \Args.context >> locality_cancellation_simprocs_add_all\ -attribute_setup locality_no_cancel = \Args.context >> locality_cancellation_simprocs_del_all\ + fun locality_cancellation_attribute enabled : attribute = + Thm.declaration_attribute (fn _ => fn context => + let + val ctxt = Context.proof_of context + val add_dispatchers = + if enabled then + let + val named_dispatchers = + locality_named_dispatchers ctxt + val present = + locality_present_raw_dispatchers + ctxt named_dispatchers + val missing = + named_dispatchers + |> filter_out (fn (_, source_name, _, _) => + Symtab.defined present source_name) + fun add_missing (_, _, _, simproc) = + Raw_Simplifier.add_proc simproc + in + Raw_Simplifier.map_ss + (fold add_missing missing) + end + else I + in + context + |> Config.put_generic locality_cancel_enabled enabled + |> add_dispatchers + end)\ + +attribute_setup locality_cancel = + \Scan.succeed (locality_cancellation_attribute true)\ +attribute_setup locality_no_cancel = + \Scan.succeed (locality_cancellation_attribute false)\ + +text\On-demand pairwise operation commutativity. The default-on cancellation simprocs only fire when +an \<^emph>\attribute\ heads the telescope; a bare \<^verbatim>\opA (opB R)\ is not rewritten. Where a proof needs the +two operations to commute, \<^verbatim>\[[locality_autocommutativity (rec) A B]]\ derives that theorem from the +footprint data and \<^emph>\returns it as a fact\ (generalized to schematics, so it applies as a rewrite or +rule) - nothing is registered permanently and the ambient simpset is not touched. It is used in a +\<^emph>\fact position\: name it with \<^verbatim>\lemmas c = [[locality_autocommutativity (rec) A B]]\, discharge a bare +op-over-op goal with \<^verbatim>\by (rule [[locality_autocommutativity (rec) A B]])\, or feed it to a tactic +with \<^verbatim>\by (simp add: [[locality_autocommutativity (rec) A B]])\. It is sound: operations with disjoint +footprints commute and yield a theorem; a footprint-sharing pair genuinely does not commute and +raises an error rather than fabricating a false theorem. The record type is given in parentheses. + +Because the attribute ignores the theorem it is applied to and synthesises a fresh one, it works +from the empty \<^verbatim>\[[\]]\ fact form (which seeds the attribute chain with \<^verbatim>\Drule.dummy_thm\): the +\<^verbatim>\Thm.rule_attribute\ guard only short-circuits on a \<^emph>\free\ dummy, whereas that seed is untagged, so +the rule function runs and its result becomes the fact. The generalization to schematics (via +\<^verbatim>\forall_intr_frees\/\<^verbatim>\forall_elim_vars\) is what makes the returned theorem \<^emph>\storable\ as a named fact +and usable as a rewrite - a \<^verbatim>\Goal.prove\ result quantifies over fixed frees, which \<^verbatim>\lemmas\ would +reject. + +The two operation arguments are parsed with \<^ML>\Args.const\ (not \<^ML>\Args.name\), so the source +tokens \<^verbatim>\A\/\<^verbatim>\B\ carry the usual constant PIDE markup - hover shows the type, ctrl-click jumps to the +definition - and misspelled operands are rejected at parse time. \<^ML>\Args.const\ already resolves to +the fully-qualified constant name the footprint database is keyed under, so it is passed straight to +\<^verbatim>\locality_prove_commutativity\.\ +attribute_setup locality_autocommutativity = + \(Scan.lift (Args.parens Parse.typ) -- Args.const {proper = false, strict = false} + -- Args.const {proper = false, strict = false}) >> (fn ((rc, a), b) => + Thm.rule_attribute [] (fn context => fn _ (* incoming (dummy) thm, discarded *) => + let + val ctxt = Context.proof_of context + val patternA = Syntax.read_term ctxt a + val patternB = Syntax.read_term ctxt b + in + case locality_prove_commutativity ctxt rc patternA patternB of + SOME thm => Thm.forall_intr_frees thm |> Thm.forall_elim_vars 0 + | NONE => error ("locality_autocommutativity: " ^ a ^ " and " ^ b + ^ " do not commute on " ^ rc) + end))\ + "derive and return (generalized) the pairwise op-commutativity theorem for the named record" + +text\For restricted simplifier calls such as \<^verbatim>\simp only\, the default cancellation +simprocs are intentionally absent. The fact attribute +\<^verbatim>\[[locality_autocancellation (rec) operation attribute index]]\ derives exactly the requested +operation/attribute projection equation on demand. The index is relative to the remaining +attribute arguments after any prefix already supplied by the proof context. In particular, +implicit locale parameters do not count. The index distinguishes registrations of one attribute +at multiple record slots. As with \<^verbatim>\locality_autocommutativity\, no theorem is +registered permanently.\ +attribute_setup locality_autocancellation = + \(Scan.lift (Args.parens Parse.typ) -- Args.const {proper = false, strict = false} + -- Args.const {proper = false, strict = false} -- Scan.lift Parse.nat) + >> (fn (((rc, operation), attribute), attribute_idx) => + Thm.rule_attribute [] (fn context => fn _ => + let + val ctxt = Context.proof_of context + val operation_pattern = Syntax.read_term ctxt operation + val attribute_pattern = Syntax.read_term ctxt attribute + in + case locality_prove_cancellation_fact ctxt rc + operation_pattern attribute_pattern attribute_idx of + SOME thm => Thm.forall_intr_frees thm |> Thm.forall_elim_vars 0 + | NONE => + error ("locality_autocancellation: " ^ operation ^ " does not cancel from " + ^ attribute ^ " at relative record argument " ^ Int.toString attribute_idx + ^ " on " ^ rc) + end))\ + "derive and return one generalized operation/attribute cancellation theorem" end diff --git a/Autogen/AutoLocality_Instrumentation.ML b/Autogen/AutoLocality_Instrumentation.ML new file mode 100644 index 00000000..4cb0ffec --- /dev/null +++ b/Autogen/AutoLocality_Instrumentation.ML @@ -0,0 +1,948 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +signature AUTOLOCALITY_INSTRUMENTATION = +sig + type run_id = int + + datatype phase = Open | Frozen + + datatype counter = + Callback_Invocations + | Callback_Some_Results + | Callback_None_Results + | Callback_Exceptions + | Callback_Interrupts + | Callback_Work_Units + | Lookup_Requests + | Lookup_Index_Probes + | Lookup_Prefix_Alternatives + | Lookup_Equality_Attempts + | Lookup_Candidates_Returned + | Lookup_Entries_Examined + | Lookup_Comparisons + | Lookup_Sort_Calls + | Lookup_Specializations + | Lookup_Whole_Registry_Scans + | Index_Nodes + | Index_Secondary_Insertions + | Index_Whole_Family_Rebuilds + | Planner_Requests + | Planner_Base_Child_Builds + | Planner_Recursive_Node_Builds + | Planner_Context_Lifts + | Planner_Application_Frames + | Planner_Swaps + | Planner_Swap_Applications + | Planner_Cancellations + | Planner_Root_Rescans + | Planner_Root_Rewrites + | Planner_Tail_Copies + | Proof_Cterms + | Proof_Fresh_Nodes + | Proof_Control_Nodes + | Proof_Compositions + | Proof_Results + | Record_Preparations + | Record_Index_Probes + | Record_Rules_Selected + | Record_Hierarchy_Scans + | Record_Simpset_Builds + | Fallback_Requests + | Fallback_Crossings + | Fallback_Whole_Term_Rewrites + | Cache_Lookups + | Cache_Hits + | Cache_Misses + | Cache_Insertions + | Cache_Persistent_Events + | Lifecycle_Registration_Attempts + | Lifecycle_Semantic_Insertions + | Lifecycle_Replays + | Lifecycle_Conflicts + | Lifecycle_Dispatcher_Insertions + | Lifecycle_Duplicate_Dispatchers + | Canonicalization_Requests + | Canonicalization_Nodes + | Canonicalization_Edges + | Canonicalization_Individualizations + | Canonicalization_Backtracks + | Canonicalization_Serializations + | Resource_Future_Joins + | Resource_Reference_Drops + | Resource_Full_GCs + | Resource_Samples + + datatype resource = + Elapsed_Microseconds + | Allocated_Bytes + | Live_Bytes + | Peak_Bytes + | Resident_Bytes + + type scenario_label = string * string + type snapshot + + val disabled_run_id: run_id + val all_counters: counter list + val counter_name: counter -> string + val all_resources: resource list + val resource_name: resource -> string + + val current_run_id: Proof.context -> run_id + val disable_run: Proof.context -> Proof.context + val restore_run_selection: + Proof.context -> Proof.context -> Proof.context + val start_run: Proof.context -> run_id * Proof.context + val start_run_with_labels: + scenario_label list -> Proof.context -> run_id * Proof.context + val reset_run: Proof.context -> run_id * Proof.context + + val phase_of: run_id -> phase option + val active_callbacks_of: run_id -> int option + val async_leases_of: run_id -> int option + val await_frozen: run_id -> bool + + val record_counter: Proof.context -> counter -> IntInf.int -> unit + val record_counters: + Proof.context -> (unit -> (counter * IntInf.int) list) -> unit + val set_resource: Proof.context -> resource -> IntInf.int -> unit + val set_resources: + Proof.context -> (unit -> (resource * IntInf.int) list) -> unit + + val with_callback: + Proof.context -> (unit -> IntInf.int) -> + (unit -> 'a option) -> 'a option + val fork_with_lease: + Proof.context -> (Proof.context -> 'a) -> 'a future + + val freeze_run: run_id -> snapshot option + val drop_run: run_id -> bool + + val snapshot_run_id: snapshot -> run_id + val snapshot_phase: snapshot -> phase + val snapshot_active_callbacks: snapshot -> int + val snapshot_async_leases: snapshot -> int + val snapshot_scenario_labels: snapshot -> scenario_label list + val snapshot_counter: snapshot -> counter -> IntInf.int + val snapshot_counters: snapshot -> (counter * IntInf.int) list + val snapshot_resource: snapshot -> resource -> IntInf.int + val snapshot_resources: snapshot -> (resource * IntInf.int) list + val snapshot_xml: snapshot -> XML.tree + val snapshot_yxml: snapshot -> string +end + +structure AutoLocality_Instrumentation: AUTOLOCALITY_INSTRUMENTATION = +struct + +type run_id = int + +datatype phase = Open | Frozen + +datatype counter = + Callback_Invocations + | Callback_Some_Results + | Callback_None_Results + | Callback_Exceptions + | Callback_Interrupts + | Callback_Work_Units + | Lookup_Requests + | Lookup_Index_Probes + | Lookup_Prefix_Alternatives + | Lookup_Equality_Attempts + | Lookup_Candidates_Returned + | Lookup_Entries_Examined + | Lookup_Comparisons + | Lookup_Sort_Calls + | Lookup_Specializations + | Lookup_Whole_Registry_Scans + | Index_Nodes + | Index_Secondary_Insertions + | Index_Whole_Family_Rebuilds + | Planner_Requests + | Planner_Base_Child_Builds + | Planner_Recursive_Node_Builds + | Planner_Context_Lifts + | Planner_Application_Frames + | Planner_Swaps + | Planner_Swap_Applications + | Planner_Cancellations + | Planner_Root_Rescans + | Planner_Root_Rewrites + | Planner_Tail_Copies + | Proof_Cterms + | Proof_Fresh_Nodes + | Proof_Control_Nodes + | Proof_Compositions + | Proof_Results + | Record_Preparations + | Record_Index_Probes + | Record_Rules_Selected + | Record_Hierarchy_Scans + | Record_Simpset_Builds + | Fallback_Requests + | Fallback_Crossings + | Fallback_Whole_Term_Rewrites + | Cache_Lookups + | Cache_Hits + | Cache_Misses + | Cache_Insertions + | Cache_Persistent_Events + | Lifecycle_Registration_Attempts + | Lifecycle_Semantic_Insertions + | Lifecycle_Replays + | Lifecycle_Conflicts + | Lifecycle_Dispatcher_Insertions + | Lifecycle_Duplicate_Dispatchers + | Canonicalization_Requests + | Canonicalization_Nodes + | Canonicalization_Edges + | Canonicalization_Individualizations + | Canonicalization_Backtracks + | Canonicalization_Serializations + | Resource_Future_Joins + | Resource_Reference_Drops + | Resource_Full_GCs + | Resource_Samples + +datatype resource = + Elapsed_Microseconds + | Allocated_Bytes + | Live_Bytes + | Peak_Bytes + | Resident_Bytes + +type scenario_label = string * string + +val disabled_run_id = 0 + +val all_counters = + [Callback_Invocations, + Callback_Some_Results, + Callback_None_Results, + Callback_Exceptions, + Callback_Interrupts, + Callback_Work_Units, + Lookup_Requests, + Lookup_Index_Probes, + Lookup_Prefix_Alternatives, + Lookup_Equality_Attempts, + Lookup_Candidates_Returned, + Lookup_Entries_Examined, + Lookup_Comparisons, + Lookup_Sort_Calls, + Lookup_Specializations, + Lookup_Whole_Registry_Scans, + Index_Nodes, + Index_Secondary_Insertions, + Index_Whole_Family_Rebuilds, + Planner_Requests, + Planner_Base_Child_Builds, + Planner_Recursive_Node_Builds, + Planner_Context_Lifts, + Planner_Application_Frames, + Planner_Swaps, + Planner_Swap_Applications, + Planner_Cancellations, + Planner_Root_Rescans, + Planner_Root_Rewrites, + Planner_Tail_Copies, + Proof_Cterms, + Proof_Fresh_Nodes, + Proof_Control_Nodes, + Proof_Compositions, + Proof_Results, + Record_Preparations, + Record_Index_Probes, + Record_Rules_Selected, + Record_Hierarchy_Scans, + Record_Simpset_Builds, + Fallback_Requests, + Fallback_Crossings, + Fallback_Whole_Term_Rewrites, + Cache_Lookups, + Cache_Hits, + Cache_Misses, + Cache_Insertions, + Cache_Persistent_Events, + Lifecycle_Registration_Attempts, + Lifecycle_Semantic_Insertions, + Lifecycle_Replays, + Lifecycle_Conflicts, + Lifecycle_Dispatcher_Insertions, + Lifecycle_Duplicate_Dispatchers, + Canonicalization_Requests, + Canonicalization_Nodes, + Canonicalization_Edges, + Canonicalization_Individualizations, + Canonicalization_Backtracks, + Canonicalization_Serializations, + Resource_Future_Joins, + Resource_Reference_Drops, + Resource_Full_GCs, + Resource_Samples] + +fun counter_name Callback_Invocations = "callback.invocations" + | counter_name Callback_Some_Results = "callback.some_results" + | counter_name Callback_None_Results = "callback.none_results" + | counter_name Callback_Exceptions = "callback.exceptions" + | counter_name Callback_Interrupts = "callback.interrupts" + | counter_name Callback_Work_Units = "callback.work_units" + | counter_name Lookup_Requests = "lookup.requests" + | counter_name Lookup_Index_Probes = "lookup.index_probes" + | counter_name Lookup_Prefix_Alternatives = "lookup.prefix_alternatives" + | counter_name Lookup_Equality_Attempts = "lookup.equality_attempts" + | counter_name Lookup_Candidates_Returned = "lookup.candidates_returned" + | counter_name Lookup_Entries_Examined = "lookup.entries_examined" + | counter_name Lookup_Comparisons = "lookup.comparisons" + | counter_name Lookup_Sort_Calls = "lookup.sort_calls" + | counter_name Lookup_Specializations = "lookup.specializations" + | counter_name Lookup_Whole_Registry_Scans = "lookup.whole_registry_scans" + | counter_name Index_Nodes = "index.nodes" + | counter_name Index_Secondary_Insertions = "index.secondary_insertions" + | counter_name Index_Whole_Family_Rebuilds = "index.whole_family_rebuilds" + | counter_name Planner_Requests = "planner.requests" + | counter_name Planner_Base_Child_Builds = "planner.base_child_builds" + | counter_name Planner_Recursive_Node_Builds = "planner.recursive_node_builds" + | counter_name Planner_Context_Lifts = "planner.context_lifts" + | counter_name Planner_Application_Frames = "planner.application_frames" + | counter_name Planner_Swaps = "planner.swaps" + | counter_name Planner_Swap_Applications = "planner.swap_applications" + | counter_name Planner_Cancellations = "planner.cancellations" + | counter_name Planner_Root_Rescans = "planner.root_rescans" + | counter_name Planner_Root_Rewrites = "planner.root_rewrites" + | counter_name Planner_Tail_Copies = "planner.tail_copies" + | counter_name Proof_Cterms = "proof.cterms" + | counter_name Proof_Fresh_Nodes = "proof.fresh_nodes" + | counter_name Proof_Control_Nodes = "proof.control_nodes" + | counter_name Proof_Compositions = "proof.compositions" + | counter_name Proof_Results = "proof.results" + | counter_name Record_Preparations = "record.preparations" + | counter_name Record_Index_Probes = "record.index_probes" + | counter_name Record_Rules_Selected = "record.rules_selected" + | counter_name Record_Hierarchy_Scans = "record.hierarchy_scans" + | counter_name Record_Simpset_Builds = "record.simpset_builds" + | counter_name Fallback_Requests = "fallback.requests" + | counter_name Fallback_Crossings = "fallback.crossings" + | counter_name Fallback_Whole_Term_Rewrites = "fallback.whole_term_rewrites" + | counter_name Cache_Lookups = "cache.lookups" + | counter_name Cache_Hits = "cache.hits" + | counter_name Cache_Misses = "cache.misses" + | counter_name Cache_Insertions = "cache.insertions" + | counter_name Cache_Persistent_Events = "cache.persistent_events" + | counter_name Lifecycle_Registration_Attempts = "lifecycle.registration_attempts" + | counter_name Lifecycle_Semantic_Insertions = "lifecycle.semantic_insertions" + | counter_name Lifecycle_Replays = "lifecycle.replays" + | counter_name Lifecycle_Conflicts = "lifecycle.conflicts" + | counter_name Lifecycle_Dispatcher_Insertions = "lifecycle.dispatcher_insertions" + | counter_name Lifecycle_Duplicate_Dispatchers = "lifecycle.duplicate_dispatchers" + | counter_name Canonicalization_Requests = "canonicalization.requests" + | counter_name Canonicalization_Nodes = "canonicalization.nodes" + | counter_name Canonicalization_Edges = "canonicalization.edges" + | counter_name Canonicalization_Individualizations = + "canonicalization.individualizations" + | counter_name Canonicalization_Backtracks = "canonicalization.backtracks" + | counter_name Canonicalization_Serializations = "canonicalization.serializations" + | counter_name Resource_Future_Joins = "resource.future_joins" + | counter_name Resource_Reference_Drops = "resource.reference_drops" + | counter_name Resource_Full_GCs = "resource.full_gcs" + | counter_name Resource_Samples = "resource.samples" + +val all_resources = + [Elapsed_Microseconds, + Allocated_Bytes, + Live_Bytes, + Peak_Bytes, + Resident_Bytes] + +fun resource_name Elapsed_Microseconds = "elapsed_microseconds" + | resource_name Allocated_Bytes = "allocated_bytes" + | resource_name Live_Bytes = "live_bytes" + | resource_name Peak_Bytes = "peak_bytes" + | resource_name Resident_Bytes = "resident_bytes" + +fun index_of what eq value values = + let + fun find _ [] = raise Fail ("Missing " ^ what ^ " in fixed vocabulary") + | find i (x :: xs) = if eq (value, x) then i else find (i + 1) xs + in find 0 values end + +fun counter_index counter = index_of "counter" (op =) counter all_counters +fun resource_index resource = index_of "resource" (op =) resource all_resources + +fun phase_name Open = "open" + | phase_name Frozen = "frozen" + +structure Run_Selection = Proof_Data +( + type T = run_id + fun init _ = disabled_run_id +) + +(* The dynamic callback capability is scalar and exists only while an admitted + callback is executing. It cannot be recovered from a stale proof context. *) +val callback_run = Thread_Data.var (): run_id Thread_Data.var + +(* Collector and snapshot payloads contain only fixed enums, integers, and + bounded strings. *) +type run_state = + {phase: phase, + active_callbacks: int, + async_leases: int, + counters: IntInf.int Inttab.table, + resources: IntInf.int Inttab.table, + scenario_labels: scenario_label list} + +type collector_state = + {last_run_id: run_id, + runs: run_state Inttab.table} + +datatype snapshot = Snapshot of + {run_id: run_id, + phase: phase, + active_callbacks: int, + async_leases: int, + counters: (counter * IntInf.int) list, + resources: (resource * IntInf.int) list, + scenario_labels: scenario_label list} + +val collector = + Synchronized.var "AutoLocality instrumentation collector" + ({last_run_id = disabled_run_id, runs = Inttab.empty}: collector_state) + +fun make_run_state phase active_callbacks async_leases counters resources scenario_labels : + run_state = + {phase = phase, + active_callbacks = active_callbacks, + async_leases = async_leases, + counters = counters, + resources = resources, + scenario_labels = scenario_labels} + +fun map_run run_id f ({last_run_id, runs}: collector_state) = + {last_run_id = last_run_id, + runs = + (case Inttab.lookup runs run_id of + NONE => runs + | SOME run => Inttab.update (run_id, f run) runs)} + +fun update_run run_id run ({last_run_id, runs}: collector_state) = + {last_run_id = last_run_id, + runs = Inttab.update (run_id, run) runs} + +fun current_run_id ctxt = Run_Selection.get ctxt +fun disable_run ctxt = Run_Selection.put disabled_run_id ctxt +fun restore_run_selection source = + Run_Selection.put (current_run_id source) + +val max_scenario_labels = 32 +val max_scenario_string_size = 256 + +fun check_scenario_string kind text = + if size text > max_scenario_string_size then + error ("AutoLocality instrumentation " ^ kind ^ " exceeds " + ^ Int.toString max_scenario_string_size ^ " bytes") + else if String.isSubstring YXML.X text orelse String.isSubstring YXML.Y text then + error ("AutoLocality instrumentation " ^ kind ^ " contains YXML control bytes") + else text + +fun canonical_scenario_labels labels = + let + val _ = + if length labels <= max_scenario_labels then () + else error ("AutoLocality instrumentation accepts at most " + ^ Int.toString max_scenario_labels ^ " scenario labels") + val labels' = + labels + |> map (fn (axis, value) => + (check_scenario_string "scenario axis" axis, + check_scenario_string "scenario value" value)) + |> sort (prod_ord string_ord string_ord) + fun check_unique [] = () + | check_unique [_] = () + | check_unique ((axis0, _) :: (entry1 as (axis1, _)) :: rest) = + if axis0 = axis1 then + error ("Duplicate AutoLocality instrumentation scenario axis " ^ quote axis0) + else check_unique (entry1 :: rest) + val _ = check_unique labels' + in labels' end + +fun next_run_id last_run_id = + (case Int.maxInt of + SOME max_int => + if last_run_id = max_int then + error "AutoLocality instrumentation exhausted monotonically increasing run IDs" + else last_run_id + 1 + | NONE => last_run_id + 1) + +fun start_run_with_labels labels ctxt = + let + val scenario_labels = canonical_scenario_labels labels + val run_id = + Synchronized.change_result collector + (fn {last_run_id, runs} => + let + val run_id = next_run_id last_run_id + val run = + make_run_state Open 0 0 Inttab.empty Inttab.empty scenario_labels + in + (run_id, + {last_run_id = run_id, + runs = Inttab.update_new (run_id, run) runs}) + end) + in (run_id, Run_Selection.put run_id ctxt) end + +fun start_run ctxt = start_run_with_labels [] ctxt + +fun phase_of run_id = + Synchronized.value collector + |> #runs + |> (fn runs => Inttab.lookup runs run_id) + |> Option.map #phase + +fun active_callbacks_of run_id = + Synchronized.value collector + |> #runs + |> (fn runs => Inttab.lookup runs run_id) + |> Option.map #active_callbacks + +fun async_leases_of run_id = + Synchronized.value collector + |> #runs + |> (fn runs => Inttab.lookup runs run_id) + |> Option.map #async_leases + +fun await_frozen run_id = + Synchronized.guarded_access collector + (fn state as {runs, ...} => + (case Inttab.lookup runs run_id of + NONE => SOME (false, state) + | SOME {phase = Frozen, ...} => SOME (true, state) + | SOME {phase = Open, ...} => NONE)) + +fun thread_has_run data run_id = + (case Thread_Data.get data of + SOME active_run_id => active_run_id = run_id + | NONE => false) + +fun state_allows_recording run_id + ({phase, active_callbacks, ...}: run_state) = + phase = Open orelse + (thread_has_run callback_run run_id andalso active_callbacks > 0) + +fun recording_available run_id = + if run_id = disabled_run_id then false + else + (case Inttab.lookup (#runs (Synchronized.value collector)) run_id of + SOME run => state_allows_recording run_id run + | NONE => false) + +fun add_value index amount values = + if amount = 0 then values + else Inttab.map_default (index, 0) (fn old => old + amount) values + +fun check_nonnegative what amount = + if amount < 0 then + error ("AutoLocality instrumentation " ^ what ^ " must be nonnegative") + else amount + +fun callback_counter Callback_Invocations = true + | callback_counter Callback_Some_Results = true + | callback_counter Callback_None_Results = true + | callback_counter Callback_Exceptions = true + | callback_counter Callback_Interrupts = true + | callback_counter Callback_Work_Units = true + | callback_counter _ = false + +fun check_explicit_counter counter = + if callback_counter counter then + error ("AutoLocality callback counter " ^ quote (counter_name counter) + ^ " is owned by with_callback") + else counter + +fun add_counter_values deltas counters = + fold (fn (counter, amount) => + add_value (counter_index counter) amount) deltas counters + +fun set_resource_values values resources = + fold (fn (resource, amount) => + Inttab.update (resource_index resource, amount)) values resources + +fun record_counters ctxt make_deltas = + let val run_id = current_run_id ctxt in + if not (recording_available run_id) then () + else + let + val deltas = + make_deltas () + |> map (fn (counter, amount) => + (check_explicit_counter counter, + check_nonnegative "counter delta" amount)) + in + Synchronized.change collector + (fn state => + map_run run_id + (fn run as + {phase, active_callbacks, async_leases, counters, resources, + scenario_labels} => + if state_allows_recording run_id run then + make_run_state phase active_callbacks async_leases + (add_counter_values deltas counters) resources scenario_labels + else run) + state) + end + end + +fun record_counter ctxt counter amount = + let val run_id = current_run_id ctxt in + if run_id = disabled_run_id then () + else + record_counters ctxt + (fn () => [(counter, check_nonnegative "counter delta" amount)]) + end + +fun set_resources ctxt make_values = + let val run_id = current_run_id ctxt in + if not (recording_available run_id) then () + else + let + val values = + make_values () + |> map (fn (resource, amount) => + (resource, check_nonnegative "resource value" amount)) + in + Synchronized.change collector + (fn state => + map_run run_id + (fn run as + {phase, active_callbacks, async_leases, counters, resources, + scenario_labels} => + if state_allows_recording run_id run then + make_run_state phase active_callbacks async_leases counters + (set_resource_values values resources) scenario_labels + else run) + state) + end + end + +fun set_resource ctxt resource amount = + let val run_id = current_run_id ctxt in + if run_id = disabled_run_id then () + else + set_resources ctxt + (fn () => [(resource, check_nonnegative "resource value" amount)]) + end + +fun admit_callback run_id = + if run_id = disabled_run_id then false + else + Synchronized.change_result collector + (fn state as {runs, ...} => + (case Inttab.lookup runs run_id of + NONE => (false, state) + | SOME + {phase, active_callbacks, async_leases, counters, resources, + scenario_labels} => + if phase = Open then + (true, + update_run run_id + (make_run_state phase (active_callbacks + 1) async_leases + counters resources scenario_labels) + state) + else (false, state))) + +fun callback_outcome_counter (Exn.Res (SOME _)) = Callback_Some_Results + | callback_outcome_counter (Exn.Res NONE) = Callback_None_Results + | callback_outcome_counter (Exn.Exn exn) = + if Exn.is_interrupt exn then Callback_Interrupts + else Callback_Exceptions + +fun finish_callback run_id result make_work = + let + val work = + (case Exn.capture0 make_work () of + Exn.Res amount => if amount < 0 then 0 else amount + | Exn.Exn _ => 0) + val deltas = + [(Callback_Invocations, 1), + (callback_outcome_counter result, 1), + (Callback_Work_Units, work)] + in + Synchronized.change collector + (fn state => + map_run run_id + (fn run as + {phase, active_callbacks, async_leases, counters, resources, + scenario_labels} => + if active_callbacks <= 0 then run + else + make_run_state phase (active_callbacks - 1) async_leases + (add_counter_values deltas counters) resources scenario_labels) + state) + end + +fun with_callback ctxt make_work callback = + let val run_id = current_run_id ctxt in + (* Keep the disabled path free of synchronized access, metadata forcing, + result capture, and event construction. *) + if run_id = disabled_run_id then callback () + else + Thread_Attributes.uninterruptible_body + (fn run => + if not (admit_callback run_id) then run callback () + else + let + val result = + Exn.capture_body + (run (fn () => + Thread_Data.setmp callback_run (SOME run_id) callback ())) + val _ = finish_callback run_id result make_work + in Exn.release result end) + end + +fun acquire_lease run_id = + if run_id = disabled_run_id then false + else + Synchronized.change_result collector + (fn state as {runs, ...} => + (case Inttab.lookup runs run_id of + SOME + {phase = Open, active_callbacks, async_leases, counters, resources, + scenario_labels} => + (true, + update_run run_id + (make_run_state Open active_callbacks (async_leases + 1) + counters resources scenario_labels) + state) + | _ => (false, state))) + +fun release_lease run_id = + Synchronized.change collector + (fn state => + map_run run_id + (fn run as + {phase, active_callbacks, async_leases, counters, resources, + scenario_labels} => + if async_leases <= 0 then run + else + make_run_state phase active_callbacks (async_leases - 1) + counters resources scenario_labels) + state) + +fun release_once released run_id = + Thread_Attributes.uninterruptible_body + (fn _ => + ignore + (Exn.capture0 + (fn () => + if Synchronized.change_result released + (fn already_released => (not already_released, true)) + then release_lease run_id + else ()) + ())) + +fun fork_in_group name group interrupts body = + (singleton o Future.forks) + {name = name, group = SOME group, deps = [], pri = 0, + interrupts = interrupts} + body + +fun fork_with_lease ctxt body = + let + val run_id = current_run_id ctxt + fun fork_target target_ctxt = + Context.setmp_generic_context (SOME (Context.Proof target_ctxt)) + (fn () => Future.fork (fn () => body target_ctxt)) () + in + Thread_Attributes.uninterruptible_body + (fn _ => + if run_id = disabled_run_id then fork_target ctxt + else + if not (acquire_lease run_id) then + fork_target (disable_run ctxt) + else + let + val released = + Synchronized.var "AutoLocality instrumentation lease" false + fun release () = release_once released run_id + val future_result = + Exn.capture_body + (fn () => fork_target ctxt) + in + (case future_result of + Exn.Exn exn => (release (); Exn.reraise exn) + | Exn.Res future => + let + (* The separately rooted watcher is the sole normal release + owner. It retains only the target handle, run_id, and + one local Boolean until the target has terminated. *) + fun cleanup_body () = + Isabelle_Thread.try_finally + (fn () => ignore (Future.join_result future)) + release + val cleanup_result = + Exn.capture_body + (fn () => + Context.setmp_generic_context NONE + (fn () => + let val cleanup_group = Future.new_group NONE in + fork_in_group + "AutoLocality instrumentation lease cleanup" + cleanup_group false cleanup_body + end) + ()) + in + (case cleanup_result of + Exn.Res _ => future + | Exn.Exn exn => + (ignore (Exn.capture0 Future.cancel future); + Isabelle_Thread.try_finally + (fn () => ignore (Future.join_result future)) + release; + Exn.reraise exn)) + end) + end) + end + +fun value_of values index = + the_default 0 (Inttab.lookup values index) + +fun sorted_counters counters = + all_counters + |> map (fn counter => (counter, value_of counters (counter_index counter))) + |> sort (string_ord o apply2 (counter_name o fst)) + +fun sorted_resources resources = + all_resources + |> map (fn resource => (resource, value_of resources (resource_index resource))) + |> sort (string_ord o apply2 (resource_name o fst)) + +fun make_snapshot run_id + ({phase, active_callbacks, async_leases, counters, resources, + scenario_labels}: run_state) = + Snapshot + {run_id = run_id, + phase = phase, + active_callbacks = active_callbacks, + async_leases = async_leases, + counters = sorted_counters counters, + resources = sorted_resources resources, + scenario_labels = scenario_labels} + +fun close_run run_id = + Synchronized.change_result collector + (fn state as {runs, ...} => + (case Inttab.lookup runs run_id of + NONE => (false, state) + | SOME {phase = Frozen, ...} => (true, state) + | SOME + {phase = Open, active_callbacks, async_leases, counters, resources, + scenario_labels} => + (true, + update_run run_id + (make_run_state Frozen active_callbacks async_leases + counters resources scenario_labels) + state))) + +fun freeze_run run_id = + if run_id = disabled_run_id orelse not (close_run run_id) then NONE + else + Synchronized.guarded_access collector + (fn state as {runs, ...} => + (case Inttab.lookup runs run_id of + NONE => SOME (NONE, state) + | SOME (run as + {phase = Frozen, active_callbacks = 0, async_leases = 0, ...}) => + SOME (SOME (make_snapshot run_id run), state) + | SOME _ => NONE)) + +fun drop_run run_id = + if run_id = disabled_run_id then false + else + Synchronized.change_result collector + (fn state as {last_run_id, runs} => + (case Inttab.lookup runs run_id of + SOME {phase = Frozen, active_callbacks = 0, async_leases = 0, ...} => + (true, + {last_run_id = last_run_id, + runs = Inttab.delete run_id runs}) + | _ => (false, state))) + +fun reset_run ctxt = + let + val run_id = current_run_id ctxt + val _ = + if run_id = disabled_run_id then () + else + (case freeze_run run_id of + NONE => () + | SOME _ => ignore (drop_run run_id)) + in start_run (disable_run ctxt) end + +fun snapshot_run_id + (Snapshot {run_id, ...}) = run_id + +fun snapshot_phase + (Snapshot {phase, ...}) = phase + +fun snapshot_active_callbacks + (Snapshot {active_callbacks, ...}) = active_callbacks + +fun snapshot_async_leases + (Snapshot {async_leases, ...}) = async_leases + +fun snapshot_scenario_labels + (Snapshot {scenario_labels, ...}) = scenario_labels + +fun snapshot_counters + (Snapshot {counters, ...}) = counters + +fun snapshot_counter snapshot counter = + snapshot_counters snapshot + |> get_first (fn (counter', value) => + if counter = counter' then SOME value else NONE) + |> the_default 0 + +fun snapshot_resources + (Snapshot {resources, ...}) = resources + +fun snapshot_resource snapshot resource = + snapshot_resources snapshot + |> get_first (fn (resource', value) => + if resource = resource' then SOME value else NONE) + |> the_default 0 + +fun snapshot_xml snapshot = + let + fun counter_xml (counter, value) = + XML.Elem + (("counter", + [("name", counter_name counter), + ("value", IntInf.toString value)]), []) + fun resource_xml (resource, value) = + XML.Elem + (("resource", + [("name", resource_name resource), + ("value", IntInf.toString value)]), []) + fun scenario_xml (axis, value) = + XML.Elem + (("scenario_label", + [("axis", axis), + ("value", value)]), []) + in + XML.Elem + (("autolocality_instrumentation_snapshot", + [("active_callbacks", Int.toString (snapshot_active_callbacks snapshot)), + ("async_leases", Int.toString (snapshot_async_leases snapshot)), + ("phase", phase_name (snapshot_phase snapshot)), + ("run_id", Int.toString (snapshot_run_id snapshot))]), + [XML.Elem (("counters", []), map counter_xml (snapshot_counters snapshot)), + XML.Elem (("resources", []), map resource_xml (snapshot_resources snapshot)), + XML.Elem + (("scenario_labels", []), + map scenario_xml (snapshot_scenario_labels snapshot))]) + end + +val snapshot_yxml = YXML.string_of o snapshot_xml + +end diff --git a/Autogen/AutoLocality_Test0.thy b/Autogen/AutoLocality_Test0.thy deleted file mode 100644 index e4c77679..00000000 --- a/Autogen/AutoLocality_Test0.thy +++ /dev/null @@ -1,177 +0,0 @@ -(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. - SPDX-License-Identifier: MIT *) - -(*<*) -theory AutoLocality_Test0 - imports AutoLens AutoLocality -begin -(*>*) - -datatype_record foo = - beef :: nat - ham :: nat - cheese :: nat - -definition has_beef :: \foo \ bool\ where - \has_beef f \ beef f > 0\ - -definition has_beef_many :: \foo \ foo \ bool\ where - \has_beef_many x y \ beef x > 0\ - -definition has_ham :: \foo \ bool\ where - \has_ham f \ ham f > 0\ - -definition has_beef2 :: \foo \ nat \ bool\ where - \has_beef2 f n \ beef f > n\ - -definition set_beef :: \nat \ foo \ foo\ where - \set_beef k \ update_beef (\_. k)\ - -definition set_ham :: \nat \ foo \ foo\ where - \set_ham k \ update_ham (\_. k)\ - -definition set_ham2 :: \foo \ nat \ foo\ where - \set_ham2 n k \ update_ham (\_. k) n\ - -abbreviation set_cheese :: \nat \ foo \ foo\ where - \set_cheese k \ update_cheese (\_. k)\ - -definition set_cheese2 :: \foo \ nat \ foo\ where - \set_cheese2 n k \ update_cheese (\_. k) n\ - -locality_lemma for foo: \set_ham\ footprint [ham] . -locality_lemma for foo: \set_beef\ footprint [beef] . - -print_theorems - -locality_lemma for foo: \has_beef\ footprint [beef] . -locality_lemma for foo: \has_beef_many\ [0] footprint [beef] . -locality_lemma for foo: \has_beef_many\ [1] footprint [beef] . - -print_theorems -print_locality_data - -locality_lemma for foo: \has_ham\ footprint [ham] . - -print_theorems - -locality_autoderive - -print_theorems - -locality_autoderive - -print_theorems - -print_locality_data for foo - -locality_check - -locality_lemma for foo: \has_beef2\ footprint [beef] . -locality_lemma for foo: \set_cheese 10\ footprint [cheese, beef] . -locality_lemma for foo: \set_cheese2\ footprint [cheese] . - -print_theorems - -locality_check - -locality_autoderive for foo - -datatype_record ('a, 'b) foo2 = - beef :: 'a - ham :: 'b - cheese :: 'b - -local_setup \lens_autogen_defs "foo2"\ -local_setup \lens_autogen_defining_equations @{attributes []} "foo2"\ -local_setup \lens_autogen_prove_lens_validity @{attributes []} "foo2"\ -ML \@{term \foo2.beef\}\ -local_setup\focus_autogen_make_field_foci @{attributes []} "foo2"\ - -export_code foo2_beef_focus in OCaml - -value [code] \focus_view foo2_beef_focus (make_foo2 (0 :: nat) 0 (0 :: nat))\ - -definition set_bham :: \'b \ ('a, 'b) foo2 \ ('a, 'b) foo2\ where - \set_bham k \ update_ham (\_. k)\ -locality_lemma for foo2: set_bham footprint [ham] . - -definition set_bcheese :: \nat \ ('a, nat) foo2 \ ('a, nat) foo2\ where - \set_bcheese k \ update_cheese (\_. k)\ -locality_lemma for foo2: set_bcheese footprint [cheese] . - -print_theorems -print_locality_data -locality_check - -print_locality_data - -thm AutoLocality_Test0_foo_locality_facts -thm AutoLocality_Test0_foo_commutativity_facts - -lemma - shows \has_ham (set_ham h (set_beef b X)) = has_ham (set_ham h X)\ -using [[locality_cancel]] by simp - -lemma - shows \has_ham (set_ham h (foo.update_beef b (set_ham h2 (set_cheese2 (set_cheese2 X d) c)))) = - has_ham (set_ham h (set_ham h2 X))\ -using [[locality_cancel]] by simp - -locale foo_locale = - fixes some_fun :: \'a \ 'a\ - assumes some_fun_invo: \some_fun \ some_fun = id\ -begin - -definition map_beef_via_fun :: \('a, 'a) foo2 \ ('a, 'a) foo2\ where - \map_beef_via_fun \ update_beef some_fun\ - -locality_lemma for foo2: map_beef_via_fun footprint [beef] - by (auto simp add: map_beef_via_fun_def) - -definition map_ham_via_fun :: \('a, 'a) foo2 \ ('a, 'a) foo2\ where - \map_ham_via_fun \ update_ham some_fun\ - -thm map_beef_via_fun_def - -locality_lemma for foo2: map_ham_via_fun footprint [ham] - by (auto simp add: map_ham_via_fun_def) - -locality_autoderive for foo2 - -print_theorems -print_locality_data - -end - -print_locality_data - -context foo_locale -begin - -print_locality_data - -end - -datatype_record TestRec = - my_field0 :: int - my_field1 :: int - -definition test_get0 :: \TestRec \ int\ where - \test_get0 r \ my_field0 r\ - -context -begin - -qualified datatype_record test_rec' = - my_field0 :: int - my_field :: int - -qualified definition test_get0' :: \test_rec' \ int\ where - \test_get0' r \ my_field0 r\ - -end - -(*<*) -end -(*>*) \ No newline at end of file diff --git a/Autogen/AutoLocality_Test1.thy b/Autogen/AutoLocality_Test1.thy deleted file mode 100644 index 8a088296..00000000 --- a/Autogen/AutoLocality_Test1.thy +++ /dev/null @@ -1,31 +0,0 @@ -(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. - SPDX-License-Identifier: MIT *) - -(*<*) -theory AutoLocality_Test1 - imports AutoLens AutoLocality -begin -(*>*) - -datatype_record test_rec = - my_field0 :: int - my_field1 :: int - -definition test_get0 :: \test_rec \ int\ where - \test_get0 r \ my_field0 r\ - -context -begin - -qualified datatype_record test_rec' = - my_field0 :: int - my_field :: int - -qualified definition test_get0' :: \test_rec' \ int\ where - \test_get0' r \ my_field0 r\ - -end - -(*<*) -end -(*>*) \ No newline at end of file diff --git a/Autogen/AutoLocality_Test2.thy b/Autogen/AutoLocality_Test2.thy deleted file mode 100644 index a95113d8..00000000 --- a/Autogen/AutoLocality_Test2.thy +++ /dev/null @@ -1,23 +0,0 @@ -(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. - SPDX-License-Identifier: MIT *) - -(*<*) -theory AutoLocality_Test2 - imports AutoLens AutoLocality AutoLocality_Test0 AutoLocality_Test1 -begin -(*>*) - -locality_lemma for AutoLocality_Test0.TestRec: - AutoLocality_Test0.test_get0 footprint [my_field0] . -locality_lemma for AutoLocality_Test1.test_rec: - AutoLocality_Test1.test_get0 footprint [my_field0] . -locality_lemma for AutoLocality_Test0.test_rec': - AutoLocality_Test0.test_get0' footprint [my_field0] . -locality_lemma for AutoLocality_Test1.test_rec': - AutoLocality_Test1.test_get0' footprint [my_field0] . - -print_locality_data - -(*<*) -end -(*>*) \ No newline at end of file diff --git a/Autogen/AutoLocality_Tests/AutoLocality_B0_All.thy b/Autogen/AutoLocality_Tests/AutoLocality_B0_All.thy new file mode 100644 index 00000000..3a664384 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_B0_All.thy @@ -0,0 +1,33 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_B0_All + imports + AutoLocality_B0_Reentry + AutoLocality_B0_Types + AutoLocality_B0_Traversal + AutoLocality_B0_Diamond_LR + AutoLocality_B0_Diamond_RL +begin +(*>*) + +section\AutoLocality B0 semantic umbrella\ + +text\ +This fast umbrella contains only semantic B0 tests and has no import path to +@{verbatim \Crush.Crush\}. A later ROOT integrator should place it in, +or directly above, the Autogen session. Crush-facing B0 tests belong in a +separate session based on Crush and enter through +@{verbatim \AutoLocality_B0_Crush_All\}. + +The conflict fixtures are not executable through this umbrella. A later ROOT +integrator should enter the left and right branch theories independently so +each branch smoke test runs. Testing merge failure in both import orders +requires the frozen pure merge API or an external expected-failure child +session; importing both branches here would make ordinary processing fail. +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_B0_Automation.thy b/Autogen/AutoLocality_Tests/AutoLocality_B0_Automation.thy new file mode 100644 index 00000000..f3ee7135 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_B0_Automation.thy @@ -0,0 +1,81 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_B0_Automation + imports + AutoLocality_Tests.AutoLocality_B0_All + Crush.Crush +begin +(*>*) + +section\Production automation paths through Crush\ + +text\ +These proofs use the high-level AutoCorrode entry point with no diagnostic +stepping and no custom branch. The first simplification phase must see the +same installed AutoLocality procedures as an ordinary downstream proof. +This theory is intentionally downstream of Crush and belongs in the separate +B0 session based on Crush, not in the semantic Autogen umbrella. +\ + +lemma b0_crush_base_record: + shows \b0_has_a (b0_set_c n (b0_set_b m R)) = b0_has_a R\ + by (crush_base) + +lemma b0_crush_base_locale: + shows \b0_global_one.b0_parent_attr + (b0_set_d n (b0_global_one.b0_child_op R)) = + b0_global_one.b0_parent_attr (b0_global_one.b0_child_op R)\ + by (crush_base) + +lemma b0_crush_base_standard_record: + shows \b0_std_has_b + (b0_std_bump_a (b0_std_set_c n R)) = + b0_std_has_b R\ + by (crush_base) + +lemma b0_crush_base_nested_traversal: + shows \b0_join_flags + (b0_walk_pred (b0_walk_set_b n R)) + (b0_walk_pred (b0_walk_set_c m R)) = + b0_join_flags (b0_walk_pred R) (b0_walk_pred R)\ + by (crush_base) + +subsection\Scoped opt-out under Crush\ + +context + notes [[locality_no_cancel]] +begin + +text\ +The following unfolding proofs are controls only: they show that the goals +remain semantically true while cancellation is disabled. The semantic suite +contains the conclusive public Simplifier probes. A negative +@{method crush_base} callback/count assertion is deferred to the frozen +instrumentation API because safely asserting method failure here would require +diagnostic or internal control. +\ + +lemma b0_crush_base_opt_out_definitional_control: + shows \b0_has_a (b0_set_c n R) = b0_has_a R\ + by (crush_base simp add: b0_has_a_def b0_set_c_def) + +context +begin + +lemma b0_crush_base_opt_out_inherited_definitional_control: + shows \b0_has_a (b0_set_d n R) = b0_has_a R\ + by (crush_base simp add: b0_has_a_def b0_set_d_def) + +end + +end + +lemma b0_crush_base_opt_out_restored: + shows \b0_has_a (b0_set_c n R) = b0_has_a R\ + by (crush_base) + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_B0_Base.thy b/Autogen/AutoLocality_Tests/AutoLocality_B0_Base.thy new file mode 100644 index 00000000..7ace13f0 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_B0_Base.thy @@ -0,0 +1,168 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_B0_Base + imports Autogen.AutoLocality +begin +(*>*) + +section\Black-box baseline and public compatibility\ + +text\ +This theory provides a small shared record for the B0 black-box suite. The +proofs deliberately use generated facts, ambient simplification, and +restricted simplification rather than inspecting AutoLocality's registry. +\ + +ML\ +structure AutoLocality_B0_Blackbox = struct + + fun capture_noninterrupt f = + (case Exn.capture f () of + Exn.Res result => SOME result + | Exn.Exn exn => + if Exn.is_interrupt exn then Exn.reraise exn else NONE) + + fun simplify_term ctxt source = + let + val cterm = Thm.cterm_of ctxt (Syntax.read_term ctxt source) + val rewrite = Simplifier.rewrite ctxt cterm + in + Thm.term_of (Thm.rhs_of rewrite) + end + + fun proves_by_ambient_simp ctxt source = + let + val goal = Syntax.read_prop ctxt source + in + Option.isSome (capture_noninterrupt (fn () => + Goal.prove ctxt [] [] goal + (fn {context, ...} => asm_full_simp_tac context 1))) + end + + fun assert_normal_form label ctxt source expected = + let + val actual = simplify_term ctxt source + val expected_term = Syntax.read_term ctxt expected + in + if Term.aconv (actual, expected_term) then () + else error ("AutoLocality B0 normal-form probe failed: " ^ label) + end + + fun assert_proves label ctxt source = + if proves_by_ambient_simp ctxt source then () + else error ("AutoLocality B0 positive simp probe failed: " ^ label) + + fun assert_not_proves label ctxt source = + if proves_by_ambient_simp ctxt source then + error ("AutoLocality B0 negative simp probe failed: " ^ label) + else () + +end +\ + +datatype_record b0_state = + b0_a :: nat + b0_b :: nat + b0_c :: nat + b0_d :: nat + +locality_init for b0_state + +definition b0_set_a :: \nat \ b0_state \ b0_state\ where + \b0_set_a n \ update_b0_a (\_. n)\ + +definition b0_set_b :: \nat \ b0_state \ b0_state\ where + \b0_set_b n \ update_b0_b (\_. n)\ + +definition b0_set_c :: \nat \ b0_state \ b0_state\ where + \b0_set_c n \ update_b0_c (\_. n)\ + +definition b0_set_d :: \nat \ b0_state \ b0_state\ where + \b0_set_d n \ update_b0_d (\_. n)\ + +definition b0_has_a :: \b0_state \ bool\ where + \b0_has_a R \ b0_a R > 0\ + +definition b0_read_b :: \b0_state \ nat\ where + \b0_read_b R \ b0_b R\ + +locality_lemma for b0_state: \b0_set_a\ footprint [b0_a] . +locality_lemma for b0_state: \b0_set_b\ footprint [b0_b] . +locality_lemma for b0_state: \b0_set_c\ footprint [b0_c] . +locality_lemma for b0_state: \b0_set_d\ footprint [b0_d] . +locality_lemma for b0_state: \b0_has_a\ footprint [b0_a] . +locality_lemma for b0_state: \b0_read_b\ footprint [b0_b] . + +subsection\Immediate same-target duplicate registration\ + +text\ +These duplicates occur immediately in the same local-theory target. They are +distinct from descendant replay: exact registration is required to be +idempotent before any import or locale morphism is involved. +\ + +locality_lemma for b0_state: \b0_set_c\ footprint [b0_c] . +locality_lemma for b0_state: \b0_has_a\ footprint [b0_a] . + +subsection\Ambient and restricted production paths\ + +lemma b0_base_ambient: + shows \b0_has_a (b0_set_c n (b0_set_b m R)) = b0_has_a R\ + by simp + +lemma b0_base_restricted: + shows \b0_has_a (b0_set_c n R) = b0_has_a R\ + by (simp only: [[locality_cancel]]) + +ML\ + val ctxt = \<^context> + val _ = AutoLocality_B0_Blackbox.assert_normal_form + "same-target duplicate registrations retain one semantic rewrite" + ctxt "b0_has_a (b0_set_c n R)" "b0_has_a R" + val _ = AutoLocality_B0_Blackbox.assert_proves + "same-target duplicate registrations remain usable" + ctxt "b0_has_a (b0_set_c n R) = b0_has_a R" +\ + +lemma b0_base_bundle: + shows \b0_has_a (b0_set_d n (b0_set_a m R)) = + b0_has_a (b0_set_a m R)\ + by (simp add: AutoLocality_B0_Base_b0_state_locality_facts) + +subsection\Generated linear certificate names\ + +lemma b0_base_operation_core_name: + shows \b0_set_a n (update_b0_b f R) = + update_b0_b f (b0_set_a n R)\ + by (rule AutoLocality_B0_Base_b0_state_local_op_b0_set_a_core) + +lemma b0_base_operation_disjoint_name: + shows \b0_b (b0_set_a n R) = b0_b R\ + by (rule AutoLocality_B0_Base_b0_state_local_op_b0_set_a_disjoint) + +lemma b0_base_attribute_core_name: + shows \b0_has_a (update_b0_b f R) = b0_has_a R\ + by (rule AutoLocality_B0_Base_b0_state_local_attr_b0_has_a_0_core) + +lemma b0_base_on_demand_cancellation: + shows \b0_has_a (b0_set_c n R) = b0_has_a R\ + by (simp only: + [[locality_autocancellation (b0_state) b0_set_c b0_has_a 0]]) + +lemma b0_base_on_demand_commutativity: + shows \b0_set_b m (b0_set_c n R) = + b0_set_c n (b0_set_b m R)\ + by (rule + [[locality_autocommutativity (b0_state) b0_set_b b0_set_c]]) + +text\Repeated record initialization is part of the public compatibility +surface and must remain idempotent.\ + +locality_init for b0_state +locality_init for b0_state + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_B0_Conflict_Base.thy b/Autogen/AutoLocality_Tests/AutoLocality_B0_Conflict_Base.thy new file mode 100644 index 00000000..cebd03dd --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_B0_Conflict_Base.thy @@ -0,0 +1,38 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_B0_Conflict_Base + imports Autogen.AutoLocality +begin +(*>*) + +section\Independent sibling-merge fixture\ + +text\ +The two child theories independently register the same shared operation and +attribute. A later ROOT integrator should enter both branches independently +so their smoke lemmas execute, but must not join them through an ordinary +theory import. Two-order merge failure requires the frozen pure merge API or +an external expected-failure child session so the expected conflict does not +abort normal processing. +\ + +datatype_record b0_conflict = + b0_conflict_a :: nat + b0_conflict_b :: nat + b0_conflict_c :: nat + +locality_init for b0_conflict + +definition b0_conflict_shared_op :: + \b0_conflict \ b0_conflict\ where + \b0_conflict_shared_op R \ update_b0_conflict_a Suc R\ + +definition b0_conflict_shared_attr :: + \b0_conflict \ bool\ where + \b0_conflict_shared_attr R \ b0_conflict_b R > 0\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_B0_Conflict_Left.thy b/Autogen/AutoLocality_Tests/AutoLocality_B0_Conflict_Left.thy new file mode 100644 index 00000000..99fe8ded --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_B0_Conflict_Left.thy @@ -0,0 +1,29 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_B0_Conflict_Left + imports AutoLocality_B0_Conflict_Base +begin +(*>*) + +locality_lemma for b0_conflict: + \b0_conflict_shared_op\ footprint [b0_conflict_a] . +locality_lemma for b0_conflict: + \b0_conflict_shared_attr\ footprint [b0_conflict_b] . + +definition b0_conflict_left_only :: + \b0_conflict \ b0_conflict\ where + \b0_conflict_left_only R \ update_b0_conflict_c Suc R\ + +locality_lemma for b0_conflict: + \b0_conflict_left_only\ footprint [b0_conflict_c] . + +lemma b0_conflict_left_fixture: + shows \b0_conflict_shared_attr (b0_conflict_left_only R) = + b0_conflict_shared_attr R\ + by simp + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_B0_Conflict_Right.thy b/Autogen/AutoLocality_Tests/AutoLocality_B0_Conflict_Right.thy new file mode 100644 index 00000000..22947d86 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_B0_Conflict_Right.thy @@ -0,0 +1,34 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_B0_Conflict_Right + imports AutoLocality_B0_Conflict_Base +begin +(*>*) + +locality_lemma for b0_conflict: + \b0_conflict_shared_op\ footprint [b0_conflict_a] . +locality_lemma for b0_conflict: + \b0_conflict_shared_attr\ footprint [b0_conflict_b] . + +definition b0_conflict_right_only :: + \b0_conflict \ bool\ where + \b0_conflict_right_only R \ b0_conflict_c R = 0\ + +locality_lemma for b0_conflict: + \b0_conflict_right_only\ footprint [b0_conflict_c] . + +lemma b0_conflict_right_fixture: + shows \b0_conflict_right_only (b0_conflict_shared_op R) = + b0_conflict_right_only R\ + by (simp only: [[locality_cancel]]) + +lemma b0_conflict_right_shared_attribute_smoke: + shows \b0_conflict_shared_attr (b0_conflict_shared_op R) = + b0_conflict_shared_attr R\ + by simp + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_B0_Crush_All.thy b/Autogen/AutoLocality_Tests/AutoLocality_B0_Crush_All.thy new file mode 100644 index 00000000..d0a12872 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_B0_Crush_All.thy @@ -0,0 +1,23 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_B0_Crush_All + imports + AutoLocality_Tests.AutoLocality_B0_All + AutoLocality_B0_Automation +begin +(*>*) + +section\AutoLocality B0 Crush umbrella\ + +text\ +This downstream umbrella combines the fast semantic B0 suite with its +representative @{method crush_base} proofs. A later ROOT integrator should +place it in a separate session based on Crush; the semantic umbrella remains +available in, or directly above, Autogen without a Crush dependency. +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_B0_Diamond_Base.thy b/Autogen/AutoLocality_Tests/AutoLocality_B0_Diamond_Base.thy new file mode 100644 index 00000000..91fb1044 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_B0_Diamond_Base.thy @@ -0,0 +1,35 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_B0_Diamond_Base + imports AutoLocality_B0_Base +begin +(*>*) + +section\Common-origin import fixture\ + +datatype_record b0_diamond = + b0_da :: nat + b0_db :: nat + b0_dc :: nat + b0_dd :: nat + +locality_init for b0_diamond + +definition b0_diamond_common_op :: + \b0_diamond \ b0_diamond\ where + \b0_diamond_common_op R \ update_b0_da Suc R\ + +definition b0_diamond_common_attr :: + \b0_diamond \ bool\ where + \b0_diamond_common_attr R \ b0_db R > 0\ + +locality_lemma for b0_diamond: + \b0_diamond_common_op\ footprint [b0_da] . +locality_lemma for b0_diamond: + \b0_diamond_common_attr\ footprint [b0_db] . + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_B0_Diamond_LR.thy b/Autogen/AutoLocality_Tests/AutoLocality_B0_Diamond_LR.thy new file mode 100644 index 00000000..8766051a --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_B0_Diamond_LR.thy @@ -0,0 +1,35 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_B0_Diamond_LR + imports + AutoLocality_B0_Diamond_Left + AutoLocality_B0_Diamond_Right +begin +(*>*) + +section\Left-then-right import join\ + +lemma b0_diamond_lr_common_origin: + shows \b0_diamond_common_attr + (b0_diamond_right_op + (b0_diamond_left_op (b0_diamond_common_op R))) = + b0_diamond_common_attr R\ + by simp + +lemma b0_diamond_lr_distinct_families: + shows \b0_diamond_left_attr + (b0_diamond_right_op (b0_diamond_left_op R)) = + b0_diamond_left_attr R\ + by (simp only: [[locality_cancel]]) + +lemma b0_diamond_lr_sibling_visibility: + shows \b0_diamond_right_attr + (b0_diamond_common_op (b0_diamond_right_op R)) = + b0_diamond_right_attr R\ + by simp + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_B0_Diamond_Left.thy b/Autogen/AutoLocality_Tests/AutoLocality_B0_Diamond_Left.thy new file mode 100644 index 00000000..1afad012 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_B0_Diamond_Left.thy @@ -0,0 +1,30 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_B0_Diamond_Left + imports AutoLocality_B0_Diamond_Base +begin +(*>*) + +definition b0_diamond_left_op :: + \b0_diamond \ b0_diamond\ where + \b0_diamond_left_op R \ update_b0_dc Suc R\ + +definition b0_diamond_left_attr :: + \b0_diamond \ nat\ where + \b0_diamond_left_attr R \ b0_da R\ + +locality_lemma for b0_diamond: + \b0_diamond_left_op\ footprint [b0_dc] . +locality_lemma for b0_diamond: + \b0_diamond_left_attr\ footprint [b0_da] . + +lemma b0_diamond_left_branch: + shows \b0_diamond_common_attr (b0_diamond_left_op R) = + b0_diamond_common_attr R\ + by simp + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_B0_Diamond_RL.thy b/Autogen/AutoLocality_Tests/AutoLocality_B0_Diamond_RL.thy new file mode 100644 index 00000000..d5406a88 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_B0_Diamond_RL.thy @@ -0,0 +1,35 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_B0_Diamond_RL + imports + AutoLocality_B0_Diamond_Right + AutoLocality_B0_Diamond_Left +begin +(*>*) + +section\Right-then-left import join\ + +lemma b0_diamond_rl_common_origin: + shows \b0_diamond_common_attr + (b0_diamond_right_op + (b0_diamond_left_op (b0_diamond_common_op R))) = + b0_diamond_common_attr R\ + by simp + +lemma b0_diamond_rl_distinct_families: + shows \b0_diamond_left_attr + (b0_diamond_right_op (b0_diamond_left_op R)) = + b0_diamond_left_attr R\ + by (simp only: [[locality_cancel]]) + +lemma b0_diamond_rl_sibling_visibility: + shows \b0_diamond_right_attr + (b0_diamond_common_op (b0_diamond_right_op R)) = + b0_diamond_right_attr R\ + by simp + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_B0_Diamond_Right.thy b/Autogen/AutoLocality_Tests/AutoLocality_B0_Diamond_Right.thy new file mode 100644 index 00000000..9160b605 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_B0_Diamond_Right.thy @@ -0,0 +1,30 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_B0_Diamond_Right + imports AutoLocality_B0_Diamond_Base +begin +(*>*) + +definition b0_diamond_right_op :: + \b0_diamond \ b0_diamond\ where + \b0_diamond_right_op R \ update_b0_dd Suc R\ + +definition b0_diamond_right_attr :: + \b0_diamond \ nat\ where + \b0_diamond_right_attr R \ b0_dc R\ + +locality_lemma for b0_diamond: + \b0_diamond_right_op\ footprint [b0_dd] . +locality_lemma for b0_diamond: + \b0_diamond_right_attr\ footprint [b0_dc] . + +lemma b0_diamond_right_branch: + shows \b0_diamond_common_attr (b0_diamond_right_op R) = + b0_diamond_common_attr R\ + by (simp only: [[locality_cancel]]) + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_B0_Lifecycle.thy b/Autogen/AutoLocality_Tests/AutoLocality_B0_Lifecycle.thy new file mode 100644 index 00000000..cc540127 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_B0_Lifecycle.thy @@ -0,0 +1,366 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_B0_Lifecycle + imports AutoLocality_B0_Base +begin +(*>*) + +section\Locale declaration, replay, and interpretation lifecycle\ + +definition b0_lineage_attr :: + \(b0_state \ nat) \ b0_state \ bool\ where + \b0_lineage_attr projection R \ projection R > 0\ + +definition b0_parent_projection :: \b0_state \ nat\ where + \b0_parent_projection R \ b0_a R\ + +definition b0_child_projection :: \b0_state \ nat\ where + \b0_child_projection R \ b0_b R\ + +locale b0_parent = + fixes step :: \nat \ nat\ +begin + +definition b0_parent_attr :: \b0_state \ bool\ where + \b0_parent_attr R \ step (b0_a R) > 0\ + +definition b0_parent_op :: \b0_state \ b0_state\ where + \b0_parent_op R \ update_b0_a step R\ + +end + +text\Registration happens on context re-entry, after the locale +definitions have been established.\ + +context b0_parent begin + +locality_lemma for b0_state: \b0_parent_attr\ footprint [b0_a] . +locality_lemma for b0_state: \b0_parent_op\ footprint [b0_a] . +locality_lemma for b0_state: + \b0_lineage_attr b0_parent_projection\ footprint [b0_a] + by (auto simp add: b0_lineage_attr_def b0_parent_projection_def) + +lemma b0_parent_ambient: + shows \b0_parent_attr (b0_set_c n R) = b0_parent_attr R\ + by simp + +lemma b0_parent_restricted: + shows \b0_parent_attr (b0_set_d n R) = b0_parent_attr R\ + by (simp only: [[locality_cancel]]) + +lemma b0_parent_dispatch_lineage: + shows \b0_lineage_attr b0_parent_projection (b0_set_c n R) = + b0_lineage_attr b0_parent_projection R\ + by simp + +end + +locale b0_child = + fixes step :: \nat \ nat\ + and shift :: \nat \ nat\ +begin + +definition b0_child_attr :: \b0_state \ bool\ where + \b0_child_attr R \ shift (b0_b R) > 1\ + +definition b0_child_op :: \b0_state \ b0_state\ where + \b0_child_op R \ update_b0_b shift R\ + +end + +text\The explicit sublocale edge composes the parent declaration +morphism before child-local semantic registrations are added.\ + +sublocale b0_child \ b0_parent step . + +context b0_child begin + +locality_lemma for b0_state: \b0_child_attr\ footprint [b0_b] . +locality_lemma for b0_state: \b0_child_op\ footprint [b0_b] . +locality_lemma for b0_state: + \b0_lineage_attr b0_child_projection\ footprint [b0_b] + by (auto simp add: b0_lineage_attr_def b0_child_projection_def) + +lemma b0_child_inherited_parent_dispatch: + shows \b0_parent_attr (b0_set_c n (b0_child_op R)) = + b0_parent_attr (b0_child_op R)\ + by simp + +lemma b0_child_semantic_registration: + shows \b0_child_attr (b0_set_d n (b0_parent_op R)) = + b0_child_attr (b0_parent_op R)\ + by (simp only: [[locality_cancel]]) + +lemma b0_child_semantic_only_family_entry: + shows \b0_lineage_attr b0_child_projection (b0_set_d n R) = + b0_lineage_attr b0_child_projection R\ + by simp + +end + +locale b0_grandchild = b0_child step shift + for step shift + + fixes twist :: \nat \ nat\ +begin + +definition b0_grandchild_op :: \b0_state \ b0_state\ where + \b0_grandchild_op R \ update_b0_c twist R\ + +definition b0_grandchild_attr :: \b0_state \ nat\ where + \b0_grandchild_attr R \ b0_d R\ + +end + +context b0_grandchild begin + +locality_lemma for b0_state: \b0_grandchild_op\ footprint [b0_c] . +locality_lemma for b0_state: \b0_grandchild_attr\ footprint [b0_d] . + +lemma b0_grandchild_nested_lifecycle: + shows \b0_grandchild_attr + (b0_child_op (b0_parent_op (b0_grandchild_op R))) = + b0_grandchild_attr R\ + by simp + +end + +subsection\Global activations and replay into distinct targets\ + +global_interpretation b0_global_one: + b0_grandchild Suc \\n. n + 2\ \\n. n * 2\ . + +global_interpretation b0_global_one_replay: + b0_grandchild Suc \\n. n + 2\ \\n. n * 2\ . + +global_interpretation b0_global_two: + b0_grandchild \\n. n + 3\ \\n. n * 3\ + \\n. n + 4\ . + +lemma b0_global_first_activation: + shows \b0_global_one.b0_parent_attr + (b0_set_d n (b0_global_one.b0_child_op R)) = + b0_global_one.b0_parent_attr (b0_global_one.b0_child_op R)\ + by simp + +lemma b0_global_exact_replay: + shows \b0_global_one.b0_child_attr + (b0_set_c n (b0_global_one.b0_parent_op R)) = + b0_global_one.b0_child_attr + (b0_global_one.b0_parent_op R)\ + by (simp only: [[locality_cancel]]) + +lemma b0_global_distinct_target: + shows \b0_global_two.b0_grandchild_attr + (b0_global_two.b0_child_op (b0_global_two.b0_parent_op R)) = + b0_global_two.b0_grandchild_attr R\ + by simp + +subsection\Interpretation into locale targets\ + +locale b0_target_left = + fixes target_step :: \nat \ nat\ +begin + +interpretation local_parent: b0_parent target_step . + +lemma b0_locale_target_left: + shows \b0_parent.b0_parent_attr target_step (b0_set_c n R) = + b0_parent.b0_parent_attr target_step R\ + by simp + +end + +locale b0_target_right = + fixes target_step :: \nat \ nat\ +begin + +interpretation local_parent: b0_parent target_step . + +lemma b0_locale_target_right: + shows \b0_parent.b0_parent_attr target_step (b0_set_d n R) = + b0_parent.b0_parent_attr target_step R\ + by (simp only: [[locality_cancel]]) + +end + +subsection\Assumption-dependent flexible prefixes\ + +locale b0_flexible_prefix = + fixes stored_prefix :: \nat \ nat\ + and actual_prefix :: \nat \ nat\ + assumes prefix_eq: \stored_prefix = actual_prefix\ +begin + +definition b0_flexible_attr :: \b0_state \ bool\ where + \b0_flexible_attr R \ stored_prefix (b0_a R) > 7\ + +end + +context b0_flexible_prefix begin + +locality_lemma for b0_state: \b0_flexible_attr\ footprint [b0_a] . + +lemma b0_flexible_prefix_ambient: + shows \b0_flexible_prefix.b0_flexible_attr actual_prefix + (b0_set_c n R) = + b0_flexible_prefix.b0_flexible_attr actual_prefix R\ + using prefix_eq + by simp + +lemma b0_flexible_prefix_restricted: + shows \b0_flexible_prefix.b0_flexible_attr actual_prefix + (b0_set_d n R) = + b0_flexible_prefix.b0_flexible_attr actual_prefix R\ + using prefix_eq + by (simp only: prefix_eq [[locality_cancel]]) + +end + +subsection\Proof-context isolation for flexible-prefix matching\ + +locale b0_context_isolation = + fixes stored_prefix :: \nat \ nat\ + and actual_prefix :: \nat \ nat\ +begin + +definition b0_isolated_attr :: \b0_state \ bool\ where + \b0_isolated_attr R \ stored_prefix (b0_a R) > 11\ + +end + +context b0_context_isolation begin + +locality_lemma for b0_state: \b0_isolated_attr\ footprint [b0_a] . + +ML\ + val ctxt = \<^context> + val _ = AutoLocality_B0_Blackbox.assert_not_proves + "flexible prefix without equality before a proving context" + ctxt + "b0_context_isolation.b0_isolated_attr actual_prefix \ + \(b0_set_c n R) = \ + \b0_context_isolation.b0_isolated_attr actual_prefix R" +\ + +context + assumes prefix_eq: \stored_prefix = actual_prefix\ +begin + +declare prefix_eq [simp] + +ML\ + val ctxt = \<^context> + val _ = AutoLocality_B0_Blackbox.assert_proves + "flexible prefix with equality after a non-proving context" + ctxt + "b0_context_isolation.b0_isolated_attr actual_prefix \ + \(b0_set_c n R) = \ + \b0_context_isolation.b0_isolated_attr actual_prefix R" +\ + +end + +ML\ + val ctxt = \<^context> + val _ = AutoLocality_B0_Blackbox.assert_not_proves + "flexible prefix without equality after a proving context" + ctxt + "b0_context_isolation.b0_isolated_attr actual_prefix \ + \(b0_set_c n R) = \ + \b0_context_isolation.b0_isolated_attr actual_prefix R" +\ + +context + assumes prefix_eq: \stored_prefix = actual_prefix\ +begin + +declare prefix_eq [simp] + +ML\ + val ctxt = \<^context> + val _ = AutoLocality_B0_Blackbox.assert_proves + "flexible prefix with equality after the second non-proving probe" + ctxt + "b0_context_isolation.b0_isolated_attr actual_prefix \ + \(b0_set_c n R) = \ + \b0_context_isolation.b0_isolated_attr actual_prefix R" +\ + +end + +end + +subsection\Scoped opt-out and restoration\ + +ML\ + val ctxt = \<^context> + val _ = AutoLocality_B0_Blackbox.assert_normal_form + "enabled cancellation removes the opaque redex" + ctxt "b0_has_a (b0_set_c n R)" "b0_has_a R" + val _ = AutoLocality_B0_Blackbox.assert_proves + "enabled cancellation proves the cancellation equation" + ctxt "b0_has_a (b0_set_c n R) = b0_has_a R" +\ + +context + notes [[locality_no_cancel]] +begin + +ML\ + val ctxt = \<^context> + val _ = AutoLocality_B0_Blackbox.assert_normal_form + "disabled cancellation retains the opaque redex" + ctxt "b0_has_a (b0_set_c n R)" "b0_has_a (b0_set_c n R)" + val _ = AutoLocality_B0_Blackbox.assert_not_proves + "disabled cancellation does not prove the cancellation equation" + ctxt "b0_has_a (b0_set_c n R) = b0_has_a R" +\ + +text\This unfolding lemma is a semantic control, not opt-out evidence.\ + +lemma b0_opt_out_definitional_control: + shows \b0_has_a (b0_set_c n R) = b0_has_a R\ + by (simp add: b0_has_a_def b0_set_c_def) + +context +begin + +ML\ + val ctxt = \<^context> + val _ = AutoLocality_B0_Blackbox.assert_normal_form + "nested disabled cancellation retains the opaque redex" + ctxt "b0_has_a (b0_set_d n R)" "b0_has_a (b0_set_d n R)" + val _ = AutoLocality_B0_Blackbox.assert_not_proves + "nested disabled cancellation does not prove the cancellation equation" + ctxt "b0_has_a (b0_set_d n R) = b0_has_a R" +\ + +text\This unfolding lemma is likewise only a semantic control.\ + +lemma b0_opt_out_nested_definitional_control: + shows \b0_has_a (b0_set_d n R) = b0_has_a R\ + by (simp add: b0_has_a_def b0_set_d_def) + +end + +end + +lemma b0_opt_out_restored: + shows \b0_has_a (b0_set_c n R) = b0_has_a R\ + by (simp only: [[locality_cancel]]) + +ML\ + val ctxt = \<^context> + val _ = AutoLocality_B0_Blackbox.assert_normal_form + "restored cancellation removes the opaque redex" + ctxt "b0_has_a (b0_set_c n R)" "b0_has_a R" + val _ = AutoLocality_B0_Blackbox.assert_proves + "restored cancellation proves the cancellation equation" + ctxt "b0_has_a (b0_set_c n R) = b0_has_a R" +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_B0_Reentry.thy b/Autogen/AutoLocality_Tests/AutoLocality_B0_Reentry.thy new file mode 100644 index 00000000..1564cb50 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_B0_Reentry.thy @@ -0,0 +1,26 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_B0_Reentry + imports AutoLocality_B0_Lifecycle +begin +(*>*) + +section\Exact registration replay\ + +text\ +Immediate same-target duplicate registrations are covered in +AutoLocality_B0_Base. Descendant locale declaration replay is +deferred to the Stage-2 registry and lifecycle tests and is not a B0 gate. +\ + +locality_init for b0_state + +lemma b0_top_level_reentry: + shows \b0_read_b (b0_set_c n (b0_set_a m R)) = b0_read_b R\ + by simp + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_B0_Traversal.thy b/Autogen/AutoLocality_Tests/AutoLocality_B0_Traversal.thy new file mode 100644 index 00000000..a278a340 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_B0_Traversal.thy @@ -0,0 +1,223 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_B0_Traversal + imports AutoLocality_B0_Base +begin +(*>*) + +section\Simplifier traversal and trigger boundaries\ + +text\ +These tests distinguish the syntax at the root from the complete recursive +walk performed by the Simplifier. Callback counts for the deliberately +non-triggering roots belong to the frozen instrumentation API; the black-box +claims here concern only the observable rewrite result. +\ + +datatype_record b0_walk = + b0_walk_a :: nat + b0_walk_b :: nat + b0_walk_c :: nat + +locality_init for b0_walk + +definition b0_walk_set_b :: + \nat \ b0_walk \ b0_walk\ where + \b0_walk_set_b n R \ update_b0_walk_b (\_. n) R\ + +definition b0_walk_set_c :: + \nat \ b0_walk \ b0_walk\ where + \b0_walk_set_c n R \ update_b0_walk_c (\_. n) R\ + +definition b0_walk_pred :: \b0_walk \ bool\ where + \b0_walk_pred R \ b0_walk_a R > 0\ + +definition b0_walk_between :: + \nat \ b0_walk \ nat \ bool\ where + \b0_walk_between lo R hi \ lo < b0_walk_a R \ + b0_walk_a R < hi\ + +locality_lemma for b0_walk: + \b0_walk_set_b\ footprint [b0_walk_b] . +locality_lemma for b0_walk: + \b0_walk_set_c\ footprint [b0_walk_c] . +locality_lemma for b0_walk: + \b0_walk_pred\ footprint [b0_walk_a] . +locality_lemma for b0_walk: + \b0_walk_between\ [0] footprint [b0_walk_a] . + +subsection\Exact family arity and fewer root arguments\ + +lemma b0_exact_family_arity: + shows \b0_walk_between lo (b0_walk_set_b n R) hi = + b0_walk_between lo R hi\ + by (simp only: [[locality_cancel]]) + +text\ +At the root, the following term is missing its final argument and contains no +complete matching descendant. The equality is established extensionally +with cancellation disabled; the white-box suite must additionally assert zero +root and nested callbacks before the extensional argument is introduced. +\ + +lemma b0_fewer_arguments_definitional_control: + shows \b0_walk_between lo (b0_walk_set_b n R) = + b0_walk_between lo R\ +proof (rule ext) + fix hi + show \b0_walk_between lo (b0_walk_set_b n R) hi = + b0_walk_between lo R hi\ + supply [[locality_no_cancel]] + by (simp add: b0_walk_between_def b0_walk_set_b_def) +qed + +ML\ + val ctxt = \<^context> + val _ = AutoLocality_B0_Blackbox.assert_normal_form + "fewer arguments with no matching descendant remain unchanged" + ctxt + "b0_walk_between lo (b0_walk_set_b n R)" + "b0_walk_between lo (b0_walk_set_b n R)" +\ + +subsection\Incomplete outer roots with matching descendants\ + +definition b0_outer_family :: \bool \ nat \ bool\ where + \b0_outer_family flag n \ flag \ n > 0\ + +lemma b0_fewer_root_arguments_nested_match: + shows \b0_outer_family + (b0_walk_pred (b0_walk_set_b n R)) = + b0_outer_family (b0_walk_pred R)\ + by (simp only: [[locality_cancel]]) + +lemma b0_different_root_head_nested_match: + shows \\ b0_walk_pred + (b0_walk_set_c n (b0_walk_set_b m R)) = + (\ b0_walk_pred R)\ + by simp + +subsection\Higher-order superterms with a proper matching prefix\ + +definition b0_higher_attr :: \b0_walk \ 'a\ where + \b0_higher_attr R \ undefined\ + +locality_lemma for b0_walk: + \b0_higher_attr\ footprint [] . + +text\ +The registered redex has result type instantiated to a function and is a +proper application prefix of the complete term. +\ + +lemma b0_extra_argument_superterm: + shows \(b0_higher_attr (b0_walk_set_b n R) :: + nat \ nat) k = + b0_higher_attr R k\ + by (simp only: [[locality_cancel]]) + +subsection\Deeply nested matches and repeated family visits\ + +definition b0_join_flags :: \bool \ bool \ bool\ where + \b0_join_flags left right \ left \ right\ + +lemma b0_deep_nested_matching_terms: + shows \b0_join_flags + (b0_walk_pred + (b0_walk_set_b n + (b0_walk_set_c m + (b0_walk_set_b p + (b0_walk_set_c q R))))) + (b0_walk_pred + (b0_walk_set_c r + (b0_walk_set_b s + (b0_walk_set_c t R)))) = + b0_join_flags (b0_walk_pred R) (b0_walk_pred R)\ + by simp + +lemma b0_nested_family_applications: + shows \b0_outer_family + (b0_join_flags + (b0_walk_pred (b0_walk_set_b n R)) + (b0_walk_pred (b0_walk_set_c m R))) = + b0_outer_family + (b0_join_flags (b0_walk_pred R) (b0_walk_pred R))\ + by (simp only: [[locality_cancel]]) + +subsection\Ambient rewrites creating and removing matches\ + +definition b0_reveal_match :: \b0_walk \ bool\ where + \b0_reveal_match R \ + b0_walk_pred (b0_walk_set_b (b0_walk_b R + 1) R)\ + +lemma b0_rewrite_creates_match_ambient: + shows \b0_reveal_match R = b0_walk_pred R\ + by (simp add: b0_reveal_match_def) + +lemma b0_rewrite_creates_match_restricted: + shows \b0_reveal_match R = b0_walk_pred R\ + by (simp only: b0_reveal_match_def [[locality_cancel]]) + +definition b0_remove_match :: \b0_walk \ bool\ where + \b0_remove_match R \ + b0_walk_pred (b0_walk_set_c (b0_walk_c R + 1) R)\ + +lemma b0_remove_match_simps [simp]: + shows \b0_remove_match R = b0_walk_pred R\ + supply [[locality_no_cancel]] + by (simp add: + b0_remove_match_def b0_walk_pred_def b0_walk_set_c_def) + +lemma b0_rewrite_removes_match: + shows \b0_remove_match R = b0_walk_pred R\ + by simp + +definition b0_remove_before_trigger :: \b0_walk \ bool\ where + \b0_remove_before_trigger R \ + (if False then b0_walk_pred (b0_walk_set_c 0 R) else True)\ + +lemma b0_remove_before_trigger_simps [simp]: + shows \b0_remove_before_trigger R\ + by (simp add: b0_remove_before_trigger_def) + +ML\ + val ctxt = \<^context> + val _ = AutoLocality_B0_Blackbox.assert_normal_form + "ambient rewrite removes the matching branch" + ctxt "b0_remove_before_trigger R" "True" + val _ = AutoLocality_B0_Blackbox.assert_not_proves + "ambient rewrite removes the matching branch before cancellation" + ctxt "b0_remove_before_trigger R = b0_walk_pred R" +\ + +subsection\Unregistered same-shape operation\ + +definition b0_walk_unregistered_a :: + \b0_walk \ b0_walk\ where + \b0_walk_unregistered_a R \ update_b0_walk_a Suc R\ + +text\ +This operation has the same operation shape as registered families but no +locality declaration. The expected equation observes its real state change; +borrowing a disjoint registered footprint would turn the goal false. +\ + +lemma b0_unregistered_operation_definitional_control: + shows \b0_walk_pred (b0_walk_unregistered_a R) = + (Suc (b0_walk_a R) > 0)\ + by (simp add: + b0_walk_pred_def b0_walk_unregistered_a_def) + +ML\ + val ctxt = \<^context> + val _ = AutoLocality_B0_Blackbox.assert_not_proves + "unregistered operation does not receive cancellation" + ctxt + "b0_walk_pred (b0_walk_unregistered_a R) = b0_walk_pred R" +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_B0_Types.thy b/Autogen/AutoLocality_Tests/AutoLocality_B0_Types.thy new file mode 100644 index 00000000..b3d66271 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_B0_Types.thy @@ -0,0 +1,249 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_B0_Types + imports AutoLocality_B0_Base +begin +(*>*) + +section\Language and type diversity\ + +subsection\Ad-hoc overloading with one source name\ + +datatype_record b0_other = + b0_x :: nat + b0_y :: nat + b0_z :: nat + +locality_init for b0_other + +consts b0_overloaded_attr :: \'a \ bool\ +consts b0_overloaded_op :: \'a \ 'a\ + +definition b0_state_concrete_attr :: \b0_state \ bool\ where + \b0_state_concrete_attr R \ b0_a R > 0\ + +definition b0_state_concrete_op :: \b0_state \ b0_state\ where + \b0_state_concrete_op R \ update_b0_b Suc R\ + +definition b0_other_concrete_attr :: \b0_other \ bool\ where + \b0_other_concrete_attr R \ b0_x R > 0\ + +definition b0_other_concrete_op :: \b0_other \ b0_other\ where + \b0_other_concrete_op R \ update_b0_y Suc R\ + +adhoc_overloading b0_overloaded_attr + \ b0_state_concrete_attr +adhoc_overloading b0_overloaded_attr + \ b0_other_concrete_attr +adhoc_overloading b0_overloaded_op + \ b0_state_concrete_op +adhoc_overloading b0_overloaded_op + \ b0_other_concrete_op + +locality_lemma for b0_state: + \b0_overloaded_attr :: b0_state \ bool\ footprint [b0_a] . +locality_lemma for b0_state: + \b0_overloaded_op :: b0_state \ b0_state\ footprint [b0_b] . +locality_lemma for b0_other: + \b0_overloaded_attr :: b0_other \ bool\ footprint [b0_x] . +locality_lemma for b0_other: + \b0_overloaded_op :: b0_other \ b0_other\ footprint [b0_y] . + +lemma b0_overloading_state_ambient: + shows \b0_overloaded_attr + (b0_set_c n (b0_overloaded_op R :: b0_state)) = + b0_overloaded_attr R\ + by simp + +lemma b0_overloading_state_restricted: + shows \b0_overloaded_attr + (b0_set_d n (b0_overloaded_op R :: b0_state)) = + b0_overloaded_attr R\ + by (simp only: [[locality_cancel]]) + +lemma b0_overloading_other_ambient: + shows \b0_overloaded_attr + (update_b0_z f (b0_overloaded_op R :: b0_other)) = + b0_overloaded_attr R\ + by simp + +lemma b0_overloading_other_restricted: + shows \b0_overloaded_attr + (update_b0_z f (b0_overloaded_op R :: b0_other)) = + b0_overloaded_attr R\ + by (simp only: [[locality_cancel]]) + +subsection\Sorted polymorphism and type-changing updates\ + +datatype_record ('a::linorder, 'phantom) b0_poly = + b0_payload :: 'a + b0_flag :: bool + b0_count :: nat + +locality_init for b0_poly + +definition b0_poly_raise :: + \'a::linorder \ + ('a, 'phantom) b0_poly \ ('a, 'phantom) b0_poly\ where + \b0_poly_raise value R \ update_b0_payload (max value) R\ + +definition b0_poly_flagged :: + \('a::linorder, 'phantom) b0_poly \ bool\ where + \b0_poly_flagged R \ b0_flag R\ + +definition b0_poly_below :: + \'a::linorder \ ('a, 'phantom) b0_poly \ bool\ where + \b0_poly_below bound R \ b0_payload R < bound\ + +locality_lemma for b0_poly: + \b0_poly_raise\ footprint [b0_payload] . +locality_lemma for b0_poly: + \b0_poly_flagged\ footprint [b0_flag] . +locality_lemma for b0_poly: + \b0_poly_below\ footprint [b0_payload] . + +lemma b0_polymorphic_ambient: + shows \b0_poly_below bound + (update_b0_count g (update_b0_flag f R)) = + b0_poly_below bound R\ + by simp + +text\Production polymorphic and phantom-changing behavior is covered by +AutoLocality_Test_Polymorphic and the later record-index stress suite.\ + +subsection\Rigid partial-application prefixes\ + +definition b0_policy_a :: \b0_state \ nat\ where + \b0_policy_a R \ b0_a R\ + +definition b0_policy_b :: \b0_state \ nat\ where + \b0_policy_b R \ b0_b R\ + +definition b0_policy_c :: \b0_state \ nat\ where + \b0_policy_c R \ b0_c R\ + +definition b0_policy_attr :: + \(b0_state \ nat) \ b0_state \ bool\ where + \b0_policy_attr policy R \ policy R > 0\ + +locality_lemma for b0_state: + \b0_policy_attr b0_policy_a\ footprint [b0_a] + by (auto simp add: b0_policy_attr_def b0_policy_a_def) +locality_lemma for b0_state: + \b0_policy_attr b0_policy_b\ footprint [b0_b] + by (auto simp add: b0_policy_attr_def b0_policy_b_def) + +lemma b0_rigid_prefix_a: + shows \b0_policy_attr b0_policy_a (b0_set_c n R) = + b0_policy_attr b0_policy_a R\ + by simp + +lemma b0_rigid_prefix_b: + shows \b0_policy_attr b0_policy_b (b0_set_a n R) = + b0_policy_attr b0_policy_b R\ + by (simp only: [[locality_cancel]]) + +text\ +The same head and arity with an unregistered rigid prefix must not borrow the +footprint of either registered prefix. This semantic control observes the +field changed by the operation, so a spurious cancellation would make the +goal false. +\ + +lemma b0_unregistered_rigid_prefix_definitional_control: + shows \b0_policy_attr b0_policy_c (b0_set_c n R) = (n > 0)\ + by (simp add: + b0_policy_attr_def b0_policy_c_def b0_set_c_def) + +ML\ + val ctxt = \<^context> + val _ = AutoLocality_B0_Blackbox.assert_not_proves + "unregistered rigid prefix does not borrow a registered footprint" + ctxt + "b0_policy_attr b0_policy_c (b0_set_c n R) = \ + \b0_policy_attr b0_policy_c R" +\ + +subsection\Higher-order update and multiple record slots\ + +definition b0_lens_c :: + \(nat \ nat) \ b0_state \ b0_state\ where + \b0_lens_c f R \ update_b0_c f R\ + +locality_lemma for b0_state: \b0_lens_c\ footprint [b0_c] . + +definition b0_pair_attr :: + \b0_state \ b0_state \ bool\ where + \b0_pair_attr L R \ b0_a L < b0_b R\ + +locality_lemma for b0_state: + \b0_pair_attr\ [0] footprint [b0_a] . +locality_lemma for b0_state: + \b0_pair_attr\ [1] footprint [b0_b] . + +lemma b0_lens_shaped_operation: + shows \b0_has_a (b0_lens_c f R) = b0_has_a R\ + by simp + +lemma b0_multiple_record_slots_ambient: + shows \b0_pair_attr (b0_set_c n L) (b0_set_a m R) = + b0_pair_attr L R\ + by simp + +lemma b0_multiple_record_slots_restricted_left: + shows \b0_pair_attr (b0_set_d n L) R = b0_pair_attr L R\ + by (simp only: [[locality_cancel]]) + +lemma b0_multiple_record_slots_restricted_right: + shows \b0_pair_attr L (b0_set_c n R) = b0_pair_attr L R\ + by (simp only: [[locality_cancel]]) + +subsection\Standard record inheritance\ + +record b0_standard_base = + b0_std_a :: nat + b0_std_b :: nat + +record b0_standard_ext = b0_standard_base + + b0_std_c :: nat + +locality_init for b0_standard_ext + +definition b0_std_bump_a :: + \b0_standard_ext \ b0_standard_ext\ where + \b0_std_bump_a R \ b0_std_a_update Suc R\ + +definition b0_std_set_c :: + \nat \ b0_standard_ext \ b0_standard_ext\ where + \b0_std_set_c n R \ b0_std_c_update (\_. n) R\ + +definition b0_std_has_b :: \b0_standard_ext \ bool\ where + \b0_std_has_b R \ b0_std_b R > 0\ + +locality_lemma for b0_standard_ext: + \b0_std_bump_a\ footprint [b0_std_a] . +locality_lemma for b0_standard_ext: + \b0_std_set_c\ footprint [b0_std_c] . +locality_lemma for b0_standard_ext: + \b0_std_has_b\ footprint [b0_std_b] . + +lemma b0_standard_extension_ambient: + shows \b0_std_has_b (b0_std_bump_a (b0_std_set_c n R)) = + b0_std_has_b R\ + by simp + +lemma b0_standard_extension_restricted: + shows \b0_std_has_b + (b0_std_a_update f (b0_std_c_update g R)) = + b0_std_has_b R\ + by (simp only: [[locality_cancel]]) + +lemma b0_standard_inherited_selector: + shows \b0_std_c (b0_std_bump_a R) = b0_std_c R\ + by simp + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_C1_Counters.thy b/Autogen/AutoLocality_Tests/AutoLocality_C1_Counters.thy new file mode 100644 index 00000000..1c9114ba --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_C1_Counters.thy @@ -0,0 +1,680 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_C1_Counters + imports Autogen.AutoLocality +begin +(*>*) + +section\AutoLocality legacy counter smoke\ + +datatype_record c1_counter_state = + c1_counter_a :: nat + c1_counter_b :: nat + c1_counter_c :: nat + c1_counter_d :: nat + +locality_init for c1_counter_state + +definition c1_counter_block_a :: + \nat \ c1_counter_state \ c1_counter_state\ where + \c1_counter_block_a n R \ + update_c1_counter_a (\old. old + n + c1_counter_a R) R\ + +definition c1_counter_front_cd :: + \c1_counter_state \ c1_counter_state\ where + \c1_counter_front_cd R \ + update_c1_counter_c Suc (update_c1_counter_d Suc R)\ + +definition c1_counter_attr_a :: \c1_counter_state \ bool\ where + \c1_counter_attr_a R \ c1_counter_a R > 0\ + +definition c1_lifecycle_attr :: \c1_counter_state \ bool\ where + \c1_lifecycle_attr R \ c1_counter_b R > 0\ + +lemma c1_lifecycle_attr_update_a: + shows \c1_lifecycle_attr (update_c1_counter_a f R) = + c1_lifecycle_attr R\ + by (simp add: c1_lifecycle_attr_def) + +lemma c1_lifecycle_attr_update_c: + shows \c1_lifecycle_attr (update_c1_counter_c f R) = + c1_lifecycle_attr R\ + by (simp add: c1_lifecycle_attr_def) + +lemma c1_lifecycle_attr_update_d: + shows \c1_lifecycle_attr (update_c1_counter_d f R) = + c1_lifecycle_attr R\ + by (simp add: c1_lifecycle_attr_def) + +locality_lemma for c1_counter_state: + \c1_counter_block_a\ footprint [c1_counter_a] . +locality_lemma for c1_counter_state: + \c1_counter_front_cd\ + footprint [c1_counter_c, c1_counter_d] . +locality_lemma for c1_counter_state: + \c1_counter_attr_a\ footprint [c1_counter_a] . + +ML\ +structure AutoLocality_C1_Counter_Smoke = +struct + +open AutoLocality_Instrumentation + +fun assert label condition = + if condition then () + else error ("AutoLocality C1 counter smoke failed: " ^ label) + +fun simplify_term ctxt source = + let + val cterm = Thm.cterm_of ctxt (Syntax.read_term ctxt source) + val rewrite = Simplifier.rewrite ctxt cterm + in Thm.term_of (Thm.rhs_of rewrite) end + +fun the_snapshot label result = + (case result of + SOME snapshot => snapshot + | NONE => error ("AutoLocality C1 counter smoke missing snapshot: " ^ label)) + +fun counters_are_zero snapshot = + forall (fn (_, value) => value = 0) (snapshot_counters snapshot) + +fun assert_term label ctxt actual expected = + let val expected_term = Syntax.read_term ctxt expected in + if Term.aconv (actual, expected_term) then () + else + error ("AutoLocality C1 counter smoke failed: " ^ label + ^ "\nActual: " ^ Syntax.string_of_term ctxt actual + ^ "\nExpected: " ^ Syntax.string_of_term ctxt expected_term) + end + +fun assert_counter_positive label snapshot counter = + assert label (snapshot_counter snapshot counter > 0) + +fun assert_counter_zero label snapshot counter = + assert label (snapshot_counter snapshot counter = 0) + +val cache_counters = + [Cache_Lookups, + Cache_Hits, + Cache_Misses, + Cache_Insertions, + Cache_Persistent_Events] + +fun assert_cache_counters_zero label snapshot = + List.app (fn counter => + assert_counter_zero + (label ^ ": " ^ counter_name counter) + snapshot counter) cache_counters + +val reserved_future_counters = + [Record_Index_Probes, + Canonicalization_Requests, + Canonicalization_Nodes, + Canonicalization_Edges, + Canonicalization_Individualizations, + Canonicalization_Backtracks, + Canonicalization_Serializations] + +fun assert_reserved_zero label snapshot = + List.app (fn counter => + assert_counter_zero + (label ^ ": reserved " ^ counter_name counter) + snapshot counter) reserved_future_counters + +fun finish_run label run_id = + let + val snapshot = the_snapshot label (freeze_run run_id) + val _ = assert (label ^ ": callbacks drained") + (snapshot_active_callbacks snapshot = 0) + val _ = assert (label ^ ": leases drained") + (snapshot_async_leases snapshot = 0) + val _ = assert (label ^ ": dropped") (drop_run run_id) + in snapshot end + +end +\ + +ML\ +local + +open AutoLocality_Instrumentation +open AutoLocality_C1_Counter_Smoke + +val depth = 16 +val head = \<^term>\Not\ +val body = \<^term>\True\ +val decomp = (replicate depth ((), (head, [], [])), body) + +in + +val _ = + let + val (run_id, ctxt) = start_run \<^context> + val _ = + op_term_with_gap_conv_with + (locality_direct_counter ctxt) decomp Conv.all_conv I + val snapshot = finish_run "linear conversion construction" run_id + val recursive_nodes = + snapshot_counter snapshot Planner_Recursive_Node_Builds + in + assert "conversion construction visits each telescope node once" + (recursive_nodes = IntInf.fromInt depth) + end + +end +\ + +ML\ +local + +open AutoLocality_C1_Counter_Smoke + +val depth = 16 +val head = \<^term>\Not\ +val body = \<^term>\True\ +val decomp = (replicate depth ((), (head, [], [])), body) + +in + +val _ = + let + val node_executions = Unsynchronized.ref 0 + val late_failures = Unsynchronized.ref 0 + + fun count_node ctm = + (node_executions := !node_executions + 1; + Conv.all_conv ctm) + + fun fail_late ctm = + (late_failures := !late_failures + 1; + Conv.no_conv ctm) + + fun fail_after_child child = + Conv.arg_conv child then_conv fail_late + + val ctm = + decomp + |> recombine_decomposed_comb + |> Thm.cterm_of \<^context> + val conversion = + op_term_with_gap_conv_with locality_no_count + decomp count_node fail_after_child + val result = conversion ctm + val _ = + assert "late-failure fallback returns reflexivity" + (Thm.is_reflexive result) + val _ = + assert ("each conversion node executes once: " + ^ Int.toString (!node_executions)) + (!node_executions = depth) + in + assert ("late failure occurs once per node: " + ^ Int.toString (!late_failures)) + (!late_failures = depth) + end + +end +\ + +locale c1_lifecycle_counter_target = + fixes c1_lifecycle_witness :: unit +begin + +local_setup \fn lthy => + let + open AutoLocality_Instrumentation + open AutoLocality_C1_Counter_Smoke + + val grouped_lthy = Local_Theory.new_group lthy + val local_fact_name = "c1_lifecycle_local_fact" + val configured_lthy = + grouped_lthy + |> Proof_Context.put_thms false + (local_fact_name, SOME [@{thm TrueI}]) + |> Config.put locality_trace_level (~1) + |> Config.put locality_timing true + |> Config.put locality_cancel_enabled false + val group_before = + Name_Space.get_group + (Local_Theory.background_naming_of configured_lthy) + val (run_id, counted_lthy) = start_run configured_lthy + val target_run_before = + current_run_id (Local_Theory.target_of counted_lthy) + val (_, rec_name) = + prepare_rec_name counted_lthy "c1_counter_state" + val pattern = + Syntax.read_term counted_lthy "c1_lifecycle_attr" + val entry = + make_locality_entry rec_name Locality_Attribute + (extract_const pattern) pattern [] + ["c1_counter_b"] 1 0 false + [@{thm c1_lifecycle_attr_update_a}, + @{thm c1_lifecycle_attr_update_c}, + @{thm c1_lifecycle_attr_update_d}] + [] NONE + val dispatch_key = + locality_dispatch_key_of_entry counted_lthy entry + val registered_lthy = + add_record_locality_entry + counted_lthy rec_name entry counted_lthy + val dispatcher_name = + (case LocalityDispatchKeyTable.lookup + (LocalityDispatcherInventory.get + (Context.Proof registered_lthy)) + dispatch_key of + SOME entry => #source_name entry + | _ => + error "First lifecycle installation has no inventory entry") + fun raw_count ctxt = + Raw_Simplifier.simpset_of ctxt + |> Raw_Simplifier.dest_ss + |> #simprocs + |> filter (fn (name, _) => name = dispatcher_name) + |> length + val first_raw_count = raw_count registered_lthy + val disabled_result = + locality_cancellation_simproc_for_dispatch + dispatch_key registered_lthy + (Thm.cterm_of registered_lthy + \<^term>\c1_lifecycle_attr + (c1_counter_front_cd R)\) + val repeated_lthy = + add_record_locality_entry + registered_lthy rec_name entry registered_lthy + val repeated_raw_count = raw_count repeated_lthy + val group_after = + Name_Space.get_group + (Local_Theory.background_naming_of repeated_lthy) + val local_fact_preserved = + (case Proof_Context.get_thms repeated_lthy local_fact_name of + [thm] => + Term.aconv (Thm.prop_of thm, Thm.prop_of @{thm TrueI}) + | _ => false) + val _ = assert + "local installation preserves run selection at each level" + (current_run_id repeated_lthy = run_id + andalso current_run_id (Local_Theory.target_of repeated_lthy) = + target_run_before) + val _ = assert "first installation preserves command group" + (Option.isSome group_before andalso group_after = group_before) + val _ = assert "first installation preserves proof-local named facts" + local_fact_preserved + val _ = assert "first installation preserves trace configuration" + (Config.get repeated_lthy locality_trace_level = ~1) + val _ = assert "first installation preserves timing configuration" + (Config.get repeated_lthy locality_timing) + val _ = assert "first installation preserves cancellation opt-out" + (not (Config.get repeated_lthy locality_cancel_enabled)) + val _ = assert "disabled installation keeps one raw dispatcher" + (first_raw_count = 1) + val _ = assert "disabled callback declines without lookup" + (case disabled_result of NONE => true | SOME _ => false) + val _ = assert "same-family registration does not duplicate dispatch" + (repeated_raw_count = 1) + val snapshot = + finish_run "first dispatcher lifecycle" run_id + val _ = + assert_counter_positive "dispatcher insertion accounting" + snapshot Lifecycle_Dispatcher_Insertions + val _ = + assert_counter_positive "duplicate dispatcher accounting" + snapshot Lifecycle_Duplicate_Dispatchers + val _ = + assert_counter_positive "semantic insertion accounting" + snapshot Lifecycle_Semantic_Insertions + val _ = + assert_counter_positive "index node accounting" + snapshot Index_Nodes + val _ = + assert_counter_positive "secondary index accounting" + snapshot Index_Secondary_Insertions + in + repeated_lthy + |> Config.put locality_trace_level 0 + |> Config.put locality_timing false + |> disable_run + end\ + +context + notes [[locality_cancel]] +begin + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_C1_Counters.c1_counter_state" + val entry = + (case select_locality_entry_for_pattern + ctxt rec_name "attribute" + \<^term>\c1_lifecycle_attr\ of + SOME value => value + | NONE => error "Missing lifecycle entry after explicit re-enable") + val dispatch_key = locality_dispatch_key_of_entry ctxt entry + val dispatcher_name = + (case LocalityDispatchKeyTable.lookup + (LocalityDispatcherInventory.get (Context.Proof ctxt)) + dispatch_key of + SOME entry => #source_name entry + | _ => error "Missing lifecycle inventory after explicit re-enable") + val raw_count = + Raw_Simplifier.simpset_of ctxt + |> Raw_Simplifier.dest_ss + |> #simprocs + |> filter (fn (name, _) => name = dispatcher_name) + |> length + val _ = + AutoLocality_C1_Counter_Smoke.assert + "explicit re-enable retains one local raw dispatcher" + (Config.get ctxt locality_cancel_enabled + andalso raw_count = 1) +\ + +lemma c1_lifecycle_explicit_reenable: + shows \c1_lifecycle_attr (c1_counter_front_cd R) = + c1_lifecycle_attr R\ + by simp + +end + +end + +ML\ +local + +open AutoLocality_Instrumentation +open AutoLocality_C1_Counter_Smoke + +val success_source = + "c1_counter_attr_a \ + \(c1_counter_block_a n (c1_counter_front_cd R))" +val success_expected = + "c1_counter_attr_a (c1_counter_block_a n R)" +val identity_source = + "c1_counter_attr_a (c1_counter_front_cd R)" +val identity_expected = + "c1_counter_attr_a R" +val field_identity_source = + "c1_counter_a (c1_counter_front_cd R)" +val field_identity_expected = + "c1_counter_a R" +val deep_identity_depth = 40 +val deep_identity_source = + fold (fn _ => fn body => + "c1_counter_front_cd (" ^ body ^ ")") + (1 upto deep_identity_depth) "R" + |> enclose "c1_counter_attr_a (" ")" +val decline_source = + "c1_counter_attr_a (c1_counter_block_a n R)" + +fun assert_enabled_exact_work snapshot = + (assert_counter_positive "lookup requests" snapshot Lookup_Requests; + assert_counter_positive "lookup index probes" snapshot + Lookup_Index_Probes; + assert_counter_positive "lookup entries" snapshot Lookup_Entries_Examined; + assert "lookup comparisons are final-candidate bounded" + (snapshot_counter snapshot Lookup_Comparisons <= + snapshot_counter snapshot Lookup_Candidates_Returned); + assert_counter_positive "lookup specialization" snapshot + Lookup_Specializations; + assert_counter_zero "whole-registry scans" snapshot + Lookup_Whole_Registry_Scans; + assert_counter_zero "lookup sorts" snapshot Lookup_Sort_Calls; + assert_counter_zero "whole-family rebuilds" snapshot + Index_Whole_Family_Rebuilds; + assert_counter_positive "planner request" snapshot Planner_Requests; + assert_counter_zero "exact swap has no planner base child" snapshot + Planner_Base_Child_Builds; + assert_counter_positive "exact swap recursive nodes" snapshot + Planner_Recursive_Node_Builds; + assert_counter_positive "exact swap context lifts" snapshot + Planner_Context_Lifts; + assert_counter_positive "exact swap application frames" snapshot + Planner_Application_Frames; + assert_counter_positive "planner swaps" snapshot Planner_Swaps; + assert_counter_positive "planner swap applications" snapshot + Planner_Swap_Applications; + assert_counter_positive "planner cancellations" snapshot + Planner_Cancellations; + assert_counter_positive "scheduled root rewrites" snapshot + Planner_Root_Rewrites; + assert_counter_zero "no root rescans" snapshot + Planner_Root_Rescans; + assert_counter_positive "exact swap tail copies" snapshot + Planner_Tail_Copies; + assert_counter_positive "proof cterms" snapshot Proof_Cterms; + assert_counter_positive "proof compositions" snapshot Proof_Compositions; + assert_counter_positive "proof results" snapshot Proof_Results; + assert_counter_positive "record preparation sentinel" snapshot + Record_Preparations; + assert_counter_positive "record rules selected" snapshot + Record_Rules_Selected; + assert_counter_positive "record simpset rebuild sentinel" snapshot + Record_Simpset_Builds; + assert_counter_zero "no fallback request" snapshot + Fallback_Requests; + assert_counter_zero "no fallback crossings" snapshot Fallback_Crossings; + assert_counter_zero "no fallback whole-term rewrites" snapshot + Fallback_Whole_Term_Rewrites) + +fun assert_root_schedule label expected snapshot = + (assert + (label ^ ": exact scheduled root rewrites") + (snapshot_counter snapshot Planner_Root_Rewrites = + IntInf.fromInt expected); + assert_counter_zero + (label ^ ": no cancellation simpset") + snapshot Record_Simpset_Builds; + assert_counter_zero + (label ^ ": no fallback request") + snapshot Fallback_Requests; + assert_counter_zero + (label ^ ": no whole-term fallback") + snapshot Fallback_Whole_Term_Rewrites) + +in + +val _ = + let + val base_context = \<^context> + + val (identity_run, identity_context) = start_run base_context + val identity_result = simplify_term identity_context identity_source + val identity_snapshot = + finish_run "already-hoisted cancellation" identity_run + val _ = assert_term "already-hoisted cancellation result" + identity_context identity_result identity_expected + val _ = assert_counter_positive "already-hoisted planner request" + identity_snapshot Planner_Requests + val _ = assert_counter_positive "already-hoisted cancellation" + identity_snapshot Planner_Cancellations + val _ = assert_root_schedule + "already-hoisted cancellation" 1 identity_snapshot + + val (field_identity_run, field_identity_context) = start_run base_context + val field_identity_result = + simplify_term field_identity_context field_identity_source + val field_identity_snapshot = + finish_run "field-selector cancellation" field_identity_run + val _ = assert_term "field-selector cancellation result" + field_identity_context field_identity_result field_identity_expected + val _ = assert_counter_positive "field-selector planner request" + field_identity_snapshot Planner_Requests + val _ = assert_counter_positive "field-selector cancellation" + field_identity_snapshot Planner_Cancellations + val _ = assert_root_schedule + "field-selector cancellation" 1 field_identity_snapshot + + val (deep_identity_run, deep_identity_context) = start_run base_context + val deep_identity_result = + simplify_term deep_identity_context deep_identity_source + val deep_identity_snapshot = + finish_run "depth-40 already-hoisted cancellation" deep_identity_run + val _ = assert_term "depth-40 already-hoisted cancellation result" + deep_identity_context deep_identity_result identity_expected + val deep_identity_cancellations = + snapshot_counter deep_identity_snapshot Planner_Cancellations + val _ = assert + ("depth-40 cancellation visits every front operation: " + ^ IntInf.toString deep_identity_cancellations) + (deep_identity_cancellations = IntInf.fromInt deep_identity_depth) + val _ = assert_root_schedule + "depth-40 cancellation" deep_identity_depth deep_identity_snapshot + + val (first_run, first_context) = start_run base_context + val first_result = simplify_term first_context success_source + val first_snapshot = + finish_run "first successful simplification" first_run + val _ = assert_term "first installed simproc result" + first_context first_result success_expected + val _ = assert_counter_positive "first callback" first_snapshot + Callback_Invocations + val _ = assert_counter_positive "first SOME outcome" first_snapshot + Callback_Some_Results + val _ = assert_counter_positive "first callback-local work" first_snapshot + Callback_Work_Units + val _ = assert_enabled_exact_work first_snapshot + val _ = + assert_cache_counters_zero "first simplification" first_snapshot + val _ = assert_reserved_zero "first simplification" first_snapshot + + val (repeated_run, repeated_context) = start_run base_context + val repeated_result = simplify_term repeated_context success_source + val repeated_snapshot = + finish_run "repeated successful simplification" repeated_run + val _ = assert_term "repeated installed simproc result" + repeated_context repeated_result success_expected + val _ = assert_counter_positive "repeated callback" repeated_snapshot + Callback_Invocations + val _ = assert_counter_positive "repeated proof results" + repeated_snapshot Proof_Results + val _ = + assert_cache_counters_zero "repeated simplification" repeated_snapshot + + val (decline_run, decline_context) = start_run base_context + val decline_result = simplify_term decline_context decline_source + val decline_snapshot = finish_run "triggered decline" decline_run + val _ = assert_term "triggered decline preserves term" + decline_context decline_result decline_source + val _ = assert_counter_positive "decline callback" decline_snapshot + Callback_Invocations + val _ = assert_counter_positive "decline NONE outcome" decline_snapshot + Callback_None_Results + val _ = assert_counter_zero "decline has no SOME outcome" decline_snapshot + Callback_Some_Results + val _ = assert_counter_positive "decline callback-local work" + decline_snapshot Callback_Work_Units + + val (disabled_source_run, selected_context) = start_run base_context + val disabled_context = disable_run selected_context + val disabled_result = simplify_term disabled_context success_source + val disabled_snapshot = + finish_run "run-ID-zero production path" disabled_source_run + val _ = assert_term "run-ID-zero preserves cancellation" + disabled_context disabled_result success_expected + val _ = assert "run-ID-zero leaves collector untouched" + (counters_are_zero disabled_snapshot) + + val (config_run, config_context0) = start_run base_context + val config_context = + Config.put locality_cancel_enabled false config_context0 + val config_result = simplify_term config_context success_source + val config_snapshot = + finish_run "Config-disabled production path" config_run + val _ = assert_term "Config false preserves the redex" + config_context config_result success_source + val _ = assert "Config false precedes callback instrumentation" + (counters_are_zero config_snapshot) + + val (reenabled_run, reenabled_context0) = start_run base_context + val reenabled_context = + reenabled_context0 + |> Config.put locality_cancel_enabled false + |> Config.put locality_cancel_enabled true + val reenabled_result = simplify_term reenabled_context success_source + val reenabled_snapshot = + finish_run "inner Config re-enable" reenabled_run + val _ = assert_term "inner Config re-enable restores cancellation" + reenabled_context reenabled_result success_expected + val _ = assert_counter_positive "inner Config re-enable callback" + reenabled_snapshot Callback_Invocations + in () end + +end +\ + +context + notes [[locality_no_cancel]] +begin + +ML\ +local + +open AutoLocality_Instrumentation +open AutoLocality_C1_Counter_Smoke + +val source = + "c1_counter_attr_a \ + \(c1_counter_block_a n (c1_counter_front_cd R))" + +in + +val _ = + let + val (run_id, ctxt) = start_run \<^context> + val result = simplify_term ctxt source + val snapshot = finish_run "scoped locality_no_cancel" run_id + val _ = assert_term "scoped locality_no_cancel preserves the redex" + ctxt result source + val _ = assert "scoped locality_no_cancel leaves counters zero" + (counters_are_zero snapshot) + in () end + +end +\ + +lemma c1_counter_explicit_fact_ignores_ambient_opt_out: + shows \c1_counter_attr_a (c1_counter_front_cd R) = + c1_counter_attr_a R\ + by (rule [[locality_autocancellation + (c1_counter_state) c1_counter_front_cd c1_counter_attr_a 0]]) + +context + notes [[locality_cancel]] +begin + +ML\ +local + +open AutoLocality_Instrumentation +open AutoLocality_C1_Counter_Smoke + +val source = + "c1_counter_attr_a \ + \(c1_counter_block_a n (c1_counter_front_cd R))" +val expected = + "c1_counter_attr_a (c1_counter_block_a n R)" + +in + +val _ = + let + val (run_id, ctxt) = start_run \<^context> + val result = simplify_term ctxt source + val snapshot = finish_run "public inner re-enable" run_id + val _ = assert_term "public locality_cancel restores cancellation" + ctxt result expected + val _ = assert_counter_positive "public re-enable callback" + snapshot Callback_Invocations + in () end + +end +\ + +end + +end + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_C1_Instrumentation.thy b/Autogen/AutoLocality_Tests/AutoLocality_C1_Instrumentation.thy new file mode 100644 index 00000000..119517fe --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_C1_Instrumentation.thy @@ -0,0 +1,393 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_C1_Instrumentation + imports Autogen.AutoLocality +begin +(*>*) + +section\AutoLocality instrumentation lifecycle smoke tests\ + +ML\ +local + +open AutoLocality_Instrumentation + +exception Smoke_Exception + +fun assert label condition = + if condition then () + else error ("AutoLocality C1 instrumentation smoke test failed: " ^ label) + +fun the_snapshot label result = + (case result of + SOME snapshot => snapshot + | NONE => error ("AutoLocality C1 instrumentation missing snapshot: " ^ label)) + +fun latch name = Synchronized.var name false + +fun signal barrier = Synchronized.change barrier (K true) + +fun await barrier = + Synchronized.guarded_access barrier + (fn ready => if ready then SOME ((), ready) else NONE) + +fun fork_thread name body = + let + val result = Synchronized.var name NONE + val _ = + Isabelle_Thread.fork (Isabelle_Thread.params name) + (fn () => + Synchronized.change result + (K (SOME (Exn.capture_body body)))) + in result end + +fun join_thread result = + Synchronized.guarded_access result + (fn state => + (case state of + NONE => NONE + | SOME value => SOME (value, state))) + |> Exn.release + +fun strictly_increasing [] = true + | strictly_increasing [_] = true + | strictly_increasing (x :: y :: rest) = + x < y andalso strictly_increasing (y :: rest) + +fun finish_run label run_id = + let + val snapshot = the_snapshot label (freeze_run run_id) + val _ = assert (label ^ ": frozen") (snapshot_phase snapshot = Frozen) + val _ = assert (label ^ ": callbacks drained") + (snapshot_active_callbacks snapshot = 0) + val _ = assert (label ^ ": leases drained") + (snapshot_async_leases snapshot = 0) + val _ = assert (label ^ ": dropped") (drop_run run_id) + in snapshot end + +val base_context = \<^context> + +val _ = assert "default run is disabled" + (current_run_id base_context = disabled_run_id) + +val (selection_run, selection_source) = start_run base_context +val rebuilt_context = + Proof_Context.init_global (Proof_Context.theory_of base_context) +val restored_selection = + restore_run_selection selection_source rebuilt_context +val restored_disabled = + restore_run_selection base_context restored_selection +val _ = assert "active run selection restores onto a rebuilt context" + (current_run_id restored_selection = selection_run) +val _ = assert "disabled run selection restores onto a rebuilt context" + (current_run_id restored_disabled = disabled_run_id) +val _ = record_counter restored_selection Lookup_Requests 1 +val selection_snapshot = + finish_run "restored run selection" selection_run +val _ = assert "restored selection records against the original run" + (snapshot_counter selection_snapshot Lookup_Requests = 1) + +val disabled_work_forced = Unsynchronized.ref false +val disabled_counter_forced = Unsynchronized.ref false +val disabled_resource_forced = Unsynchronized.ref false +val disabled_result = + with_callback base_context + (fn () => (disabled_work_forced := true; 1)) + (fn () => SOME 7) +val _ = + record_counters base_context + (fn () => (disabled_counter_forced := true; [(Lookup_Requests, 1)])) +val _ = + set_resources base_context + (fn () => (disabled_resource_forced := true; [(Live_Bytes, 1)])) +val _ = assert "disabled callback result" + (disabled_result = SOME 7) +val _ = assert "disabled callback does not force work" + (not (! disabled_work_forced)) +val _ = assert "disabled counters do not force payload" + (not (! disabled_counter_forced)) +val _ = assert "disabled resources do not force payload" + (not (! disabled_resource_forced)) + +val (outcome_run, outcome_context) = + start_run_with_labels + [("provenance", "original"), ("position", "root")] + base_context +val some_result = + with_callback outcome_context (fn () => 2) (fn () => SOME 11) +val none_result = + with_callback outcome_context (fn () => 3) (fn () => NONE) +val cleanup_result = + with_callback outcome_context (fn () => raise Smoke_Exception) + (fn () => SOME 13) +val exception_result = + Exn.capture_body + (fn () => + with_callback outcome_context (fn () => 5) + (fn () => raise Smoke_Exception)) +val interrupt_result = + Exn.capture_body + (fn () => + with_callback outcome_context (fn () => 7) + Isabelle_Thread.raise_interrupt) +val outcome_snapshot = + the_snapshot "callback outcomes" (freeze_run outcome_run) +val _ = assert "SOME result preserved" (some_result = SOME 11) +val _ = assert "NONE result preserved" (is_none none_result) +val _ = assert "cleanup failure does not replace callback result" + (cleanup_result = SOME 13) +val _ = assert "ordinary exception preserved" + (case exception_result of + Exn.Exn Smoke_Exception => true + | _ => false) +val _ = assert "interrupt preserved" + (case interrupt_result of + Exn.Exn Exn.Interrupt_Break => true + | _ => false) +val _ = assert "callback count" + (snapshot_counter outcome_snapshot Callback_Invocations = 5) +val _ = assert "SOME count" + (snapshot_counter outcome_snapshot Callback_Some_Results = 2) +val _ = assert "NONE count" + (snapshot_counter outcome_snapshot Callback_None_Results = 1) +val _ = assert "exception count" + (snapshot_counter outcome_snapshot Callback_Exceptions = 1) +val _ = assert "interrupt count" + (snapshot_counter outcome_snapshot Callback_Interrupts = 1) +val _ = assert "callback work" + (snapshot_counter outcome_snapshot Callback_Work_Units = 17) +val _ = assert "future counters default to zero" + (snapshot_counter outcome_snapshot Planner_Root_Rescans = 0 andalso + snapshot_counter outcome_snapshot Cache_Persistent_Events = 0 andalso + snapshot_counter outcome_snapshot Canonicalization_Backtracks = 0) +val _ = assert "outcome run drops" (drop_run outcome_run) + +val (callback_race_run, callback_race_context) = start_run base_context +val callback_entered = latch "AutoLocality C1 callback entered" +val callback_release = latch "AutoLocality C1 callback release" +val frozen_work_forced = Unsynchronized.ref false +val callback_thread = + fork_thread "AutoLocality C1 callback thread" + (fn () => + with_callback callback_race_context (fn () => 1) + (fn () => + (signal callback_entered; + await callback_release; + SOME ()))) +val _ = await callback_entered +val callback_releaser = + fork_thread "AutoLocality C1 callback releaser" + (fn () => + Isabelle_Thread.try_finally + (fn () => + let + val _ = assert "callback race reaches Frozen" + (await_frozen callback_race_run) + val result = + with_callback callback_race_context + (fn () => (frozen_work_forced := true; 1)) + (fn () => SOME 19) + val _ = assert "closed admission preserves callback result" + (result = SOME 19) + in + assert "closed admission does not force work" + (not (! frozen_work_forced)) + end) + (fn () => signal callback_release)) +val callback_race_snapshot = + the_snapshot "freeze/callback race" (freeze_run callback_race_run) +val _ = join_thread callback_thread +val _ = join_thread callback_releaser +val _ = assert "freeze waited for active callback" + (snapshot_counter callback_race_snapshot Callback_Invocations = 1) +val _ = assert "callback race drops" (drop_run callback_race_run) + +val (lease_run, lease_context) = start_run base_context +val leased_callback_entered = latch "AutoLocality C1 leased callback entered" +val leased_body_release = latch "AutoLocality C1 leased body release" +val leased_work_forced = Unsynchronized.ref false +val leased_future = + fork_with_lease lease_context + (fn leased_context => + let + val _ = assert "leased future sees Frozen" (await_frozen lease_run) + val result = + with_callback leased_context + (fn () => (leased_work_forced := true; 9)) + (fn () => (signal leased_callback_entered; SOME 29)) + val _ = await leased_body_release + in result end) +val lease_releaser = + fork_thread "AutoLocality C1 lease releaser" + (fn () => + Isabelle_Thread.try_finally + (fn () => + (await leased_callback_entered; + assert "lease remains active while body is blocked" + (async_leases_of lease_run = SOME 1))) + (fn () => signal leased_body_release)) +val lease_freezer = + fork_thread "AutoLocality C1 lease freezer" + (fn () => freeze_run lease_run) +val leased_result = Future.join leased_future +val lease_snapshot = + the_snapshot "blocked leased future" (join_thread lease_freezer) +val _ = join_thread lease_releaser +val _ = assert "leased callback after freeze preserves result" + (leased_result = SOME 29) +val _ = assert "leased callback after freeze does not force work" + (not (! leased_work_forced)) +val _ = assert "leased callback after freeze is not admitted" + (snapshot_counter lease_snapshot Callback_Invocations = 0 andalso + snapshot_counter lease_snapshot Callback_Some_Results = 0 andalso + snapshot_counter lease_snapshot Callback_None_Results = 0 andalso + snapshot_counter lease_snapshot Callback_Exceptions = 0 andalso + snapshot_counter lease_snapshot Callback_Interrupts = 0 andalso + snapshot_counter lease_snapshot Callback_Work_Units = 0) +val _ = assert "blocked leased future drains" + (snapshot_async_leases lease_snapshot = 0) +val _ = assert "lease run drops" (drop_run lease_run) + +val (cancelled_lease_run, cancelled_lease_context) = start_run base_context +val cancelled_lease_entered = latch "AutoLocality C1 cancelled lease entered" +val cancelled_lease_block = latch "AutoLocality C1 cancelled lease block" +val cancelled_lease_future = + fork_with_lease cancelled_lease_context + (fn _ => + (signal cancelled_lease_entered; + await cancelled_lease_block)) +val cancelled_lease_canceller = + fork_thread "AutoLocality C1 lease canceller" + (fn () => + (await cancelled_lease_entered; + Future.cancel cancelled_lease_future)) +val cancelled_lease_result = Future.join_result cancelled_lease_future +val _ = join_thread cancelled_lease_canceller +val _ = assert "leased future cancellation is observable" + (Exn.is_interrupt_exn cancelled_lease_result) +val cancelled_lease_snapshot = + the_snapshot "cancelled leased future" (freeze_run cancelled_lease_run) +val _ = assert "cancelled leased future releases its lease" + (snapshot_async_leases cancelled_lease_snapshot = 0) +val _ = assert "cancelled lease run drops" (drop_run cancelled_lease_run) + +val (retry_run, retry_context) = start_run base_context +val retry_callback_entered = latch "AutoLocality C1 retry callback entered" +val retry_callback_release = latch "AutoLocality C1 retry callback release" +val retry_callback_thread = + fork_thread "AutoLocality C1 retry callback" + (fn () => + with_callback retry_context (fn () => 1) + (fn () => + (signal retry_callback_entered; + await retry_callback_release; + SOME ()))) +val _ = await retry_callback_entered +val interrupted_freeze = + Future.fork (fn () => freeze_run retry_run) +val freeze_canceller = + fork_thread "AutoLocality C1 freeze canceller" + (fn () => + Isabelle_Thread.try_finally + (fn () => + assert "interrupted freeze closed admission" (await_frozen retry_run)) + (fn () => Future.cancel interrupted_freeze)) +val interrupted_freeze_result = Future.join_result interrupted_freeze +val _ = join_thread freeze_canceller +val _ = assert "freeze interruption is observable" + (Exn.is_interrupt_exn interrupted_freeze_result) +val _ = assert "interrupted freeze remains Frozen" + (phase_of retry_run = SOME Frozen) +val _ = signal retry_callback_release +val _ = join_thread retry_callback_thread +val retry_snapshot = + the_snapshot "interrupted freeze retry" (freeze_run retry_run) +val _ = assert "freeze retry drains callback" + (snapshot_counter retry_snapshot Callback_Invocations = 1) +val _ = assert "retry run drops" (drop_run retry_run) + +val (stale_run, stale_context) = start_run base_context +val _ = finish_run "stale context setup" stale_run +val stale_work_forced = Unsynchronized.ref false +val stale_counter_forced = Unsynchronized.ref false +val stale_result = + with_callback stale_context + (fn () => (stale_work_forced := true; 1)) + (fn () => SOME 23) +val _ = + record_counters stale_context + (fn () => (stale_counter_forced := true; [(Lookup_Requests, 1)])) +val stale_future = + fork_with_lease stale_context current_run_id +val _ = assert "stale callback remains functional" + (stale_result = SOME 23) +val _ = assert "stale callback does not force work" + (not (! stale_work_forced)) +val _ = assert "stale counter payload is inert" + (not (! stale_counter_forced)) +val _ = assert "stale future context is disabled" + (Future.join stale_future = disabled_run_id) +val _ = assert "stale freeze is inert" (is_none (freeze_run stale_run)) +val _ = assert "stale drop is inert" (not (drop_run stale_run)) + +fun start_drop 0 ids = rev ids + | start_drop n ids = + let + val (run_id, _) = start_run base_context + val _ = finish_run "repeated start/drop" run_id + in start_drop (n - 1) (run_id :: ids) end + +val repeated_ids = start_drop 16 [] +val _ = assert "run IDs are strictly monotonic" + (strictly_increasing repeated_ids) +val _ = assert "run IDs are never reused" + (length repeated_ids = length (distinct (op =) repeated_ids)) + +val (reset_source_run, reset_source_context) = start_run base_context +val (reset_run_id, reset_context) = reset_run reset_source_context +val _ = assert "reset allocates a fresh ID" + (reset_run_id > reset_source_run andalso + current_run_id reset_context = reset_run_id) +val _ = assert "reset physically removes its source run" + (phase_of reset_source_run = NONE) +val _ = finish_run "reset target" reset_run_id + +val (encoding_run, encoding_context) = + start_run_with_labels [("zeta", "last"), ("alpha", "first")] base_context +val _ = record_counter encoding_context Lookup_Requests 3 +val _ = record_counter encoding_context Planner_Requests 2 +val _ = set_resource encoding_context Resident_Bytes 4096 +val _ = set_resource encoding_context Elapsed_Microseconds 17 +val encoding_snapshot = + the_snapshot "deterministic encoding" (freeze_run encoding_run) +val encoding1 = snapshot_yxml encoding_snapshot +val encoding2 = snapshot_yxml encoding_snapshot +val counter_names = map (counter_name o fst) (snapshot_counters encoding_snapshot) +val resource_names = map (resource_name o fst) (snapshot_resources encoding_snapshot) +val _ = assert "scenario labels are sorted" + (snapshot_scenario_labels encoding_snapshot = + [("alpha", "first"), ("zeta", "last")]) +val _ = assert "counter encoding order is sorted" + (counter_names = sort_strings counter_names) +val _ = assert "resource encoding order is sorted" + (resource_names = sort_strings resource_names) +val _ = assert "snapshot encoding is deterministic" + (encoding1 = encoding2 andalso YXML.is_wellformed encoding1) +val _ = assert "snapshot carries all fixed counters" + (length (snapshot_counters encoding_snapshot) = length all_counters) +val _ = assert "snapshot carries all fixed resources" + (length (snapshot_resources encoding_snapshot) = length all_resources) +val _ = assert "encoding run drops" (drop_run encoding_run) + +in + +val _ = writeln "AutoLocality C1 instrumentation lifecycle smoke tests passed" + +end +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_C1_Locale_Retention.thy b/Autogen/AutoLocality_Tests/AutoLocality_C1_Locale_Retention.thy new file mode 100644 index 00000000..9cc156b2 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_C1_Locale_Retention.thy @@ -0,0 +1,284 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_C1_Locale_Retention + imports Autogen.AutoLocality +begin +(*>*) + +section\Collector-free locale interpretation retention\ + +datatype_record retention_state = + retention_left :: nat + retention_right :: nat + +locality_init for retention_state + +definition retention_set_right :: + \nat \ retention_state \ retention_state\ where + \retention_set_right n \ + update_retention_right (\_. n)\ + +locality_lemma for retention_state: + \retention_set_right\ footprint [retention_right] . + +locale retention_family = + fixes delta :: nat +begin + +definition retention_op :: + \retention_state \ retention_state\ where + \retention_op R \ + update_retention_left (\n. n + delta) R\ + +definition retention_attr :: \retention_state \ bool\ where + \retention_attr R \ delta < retention_left R\ + +end + +context retention_family begin + +locality_lemma for retention_state: + \retention_op\ footprint [retention_left] . + +locality_lemma for retention_state: + \retention_attr\ footprint [retention_left] . + +end + +ML\ +structure AutoLocality_C1_Locale_Retention = +struct + +open AutoLocality_Instrumentation + +val retention_dispatch_head = + "AutoLocality_C1_Locale_Retention.retention_family.retention_attr" + +val retention_operation_head = + "AutoLocality_C1_Locale_Retention.retention_family.retention_op" + +val retention_record_name = + "AutoLocality_C1_Locale_Retention.retention_state" + +fun assert_interpretation_state interpretations ctxt = + let + val inventory_entries = + LocalityDispatcherInventory.get (Context.Proof ctxt) + |> LocalityDispatchKeyTable.dest + |> filter (fn (key, _) => + #head_name key = retention_dispatch_head) + val raw_dispatchers = + Raw_Simplifier.simpset_of ctxt + |> Raw_Simplifier.dest_ss + |> #simprocs + val semantic_entries = + get_record_locality_entries retention_record_name ctxt + fun semantic_count kind head_name = + semantic_entries + |> filter (fn entry => + locality_entry_kind entry = kind + andalso #const_name entry = head_name) + |> length + val _ = + (case (interpretations, inventory_entries) of + (0, []) => () + | (_, [(_, entry)]) => + let + val alias = #alias entry + val checked_alias = + #1 (Simplifier.check_simproc + ctxt (alias, Position.none)) + val matching_raw = + raw_dispatchers + |> filter (fn (name, _) => + name = #source_name entry) + in + if checked_alias = alias + andalso length matching_raw = 1 + then () + else + error ("Retention dispatcher identity changed after " + ^ Int.toString interpretations + ^ " interpretations") + end + | _ => + error "Unexpected retention dispatcher inventory shape") + val _ = + if semantic_count Locality_Operation retention_operation_head = + interpretations + andalso semantic_count Locality_Attribute retention_dispatch_head = + interpretations + then () + else + error "Retention semantic entry count changed unexpectedly" + in + () + end + +fun statistic properties name = + (case AList.lookup (op =) properties name of + NONE => error ("Missing ML statistic " ^ quote name) + | SOME text => + (case IntInf.fromString text of + NONE => + error ("Malformed ML statistic " ^ quote name ^ ": " ^ quote text) + | SOME value => + if value < 0 then + error ("Negative ML statistic " ^ quote name ^ ": " ^ quote text) + else (text, value))) + +fun sample interpretations thy ctxt = + let + val run_id = current_run_id ctxt + val _ = + if run_id = disabled_run_id andalso run_id = 0 then () + else error "AutoLocality retention sampling requires disabled instrumentation" + val _ = assert_interpretation_state interpretations ctxt + val _ = Thm.consolidate_theory thy + val _ = ML_Heap.full_gc () + val properties = ML_Statistics.get () + val ((size_heap_raw, size_heap), + (size_heap_free_last_full_gc_raw, size_heap_free_last_full_gc)) = + (statistic properties "size_heap", + statistic properties "size_heap_free_last_full_GC") + val live_bytes = size_heap - size_heap_free_last_full_gc + val _ = + if live_bytes >= 0 then () + else + error ("Inconsistent ML heap statistics: size_heap=" ^ + size_heap_raw ^ " size_heap_free_last_full_GC=" ^ + size_heap_free_last_full_gc_raw) + in + writeln ("[AUTOLOCALITY_RETENTION] interpretations=" ^ + Int.toString interpretations ^ " live_bytes=" ^ + IntInf.toString live_bytes) + end + +end +\ + +ML\ + AutoLocality_C1_Locale_Retention.sample 0 \<^theory> \<^context> +\ + +subsection\Interpretations 1--16\ + +global_interpretation retention_01: retention_family 1 . +global_interpretation retention_02: retention_family 2 . +global_interpretation retention_03: retention_family 3 . +global_interpretation retention_04: retention_family 4 . +global_interpretation retention_05: retention_family 5 . +global_interpretation retention_06: retention_family 6 . +global_interpretation retention_07: retention_family 7 . +global_interpretation retention_08: retention_family 8 . +global_interpretation retention_09: retention_family 9 . +global_interpretation retention_10: retention_family 10 . +global_interpretation retention_11: retention_family 11 . +global_interpretation retention_12: retention_family 12 . +global_interpretation retention_13: retention_family 13 . +global_interpretation retention_14: retention_family 14 . +global_interpretation retention_15: retention_family 15 . +global_interpretation retention_16: retention_family 16 . + +lemma retention_16_cancellation: + shows \retention_16.retention_attr + (retention_set_right n (retention_16.retention_op R)) = + retention_16.retention_attr (retention_16.retention_op R)\ + by simp + +ML\ + AutoLocality_C1_Locale_Retention.sample 16 \<^theory> \<^context> +\ + +subsection\Interpretations 17--32\ + +global_interpretation retention_17: retention_family 17 . +global_interpretation retention_18: retention_family 18 . +global_interpretation retention_19: retention_family 19 . +global_interpretation retention_20: retention_family 20 . +global_interpretation retention_21: retention_family 21 . +global_interpretation retention_22: retention_family 22 . +global_interpretation retention_23: retention_family 23 . +global_interpretation retention_24: retention_family 24 . +global_interpretation retention_25: retention_family 25 . +global_interpretation retention_26: retention_family 26 . +global_interpretation retention_27: retention_family 27 . +global_interpretation retention_28: retention_family 28 . +global_interpretation retention_29: retention_family 29 . +global_interpretation retention_30: retention_family 30 . +global_interpretation retention_31: retention_family 31 . +global_interpretation retention_32: retention_family 32 . + +lemma retention_32_cancellation: + shows \retention_32.retention_attr + (retention_set_right n (retention_32.retention_op R)) = + retention_32.retention_attr (retention_32.retention_op R)\ + by simp + +ML\ + AutoLocality_C1_Locale_Retention.sample 32 \<^theory> \<^context> +\ + +subsection\Interpretations 33--48\ + +global_interpretation retention_33: retention_family 33 . +global_interpretation retention_34: retention_family 34 . +global_interpretation retention_35: retention_family 35 . +global_interpretation retention_36: retention_family 36 . +global_interpretation retention_37: retention_family 37 . +global_interpretation retention_38: retention_family 38 . +global_interpretation retention_39: retention_family 39 . +global_interpretation retention_40: retention_family 40 . +global_interpretation retention_41: retention_family 41 . +global_interpretation retention_42: retention_family 42 . +global_interpretation retention_43: retention_family 43 . +global_interpretation retention_44: retention_family 44 . +global_interpretation retention_45: retention_family 45 . +global_interpretation retention_46: retention_family 46 . +global_interpretation retention_47: retention_family 47 . +global_interpretation retention_48: retention_family 48 . + +lemma retention_48_cancellation: + shows \retention_48.retention_attr + (retention_set_right n (retention_48.retention_op R)) = + retention_48.retention_attr (retention_48.retention_op R)\ + by simp + +ML\ + AutoLocality_C1_Locale_Retention.sample 48 \<^theory> \<^context> +\ + +subsection\Interpretations 49--64\ + +global_interpretation retention_49: retention_family 49 . +global_interpretation retention_50: retention_family 50 . +global_interpretation retention_51: retention_family 51 . +global_interpretation retention_52: retention_family 52 . +global_interpretation retention_53: retention_family 53 . +global_interpretation retention_54: retention_family 54 . +global_interpretation retention_55: retention_family 55 . +global_interpretation retention_56: retention_family 56 . +global_interpretation retention_57: retention_family 57 . +global_interpretation retention_58: retention_family 58 . +global_interpretation retention_59: retention_family 59 . +global_interpretation retention_60: retention_family 60 . +global_interpretation retention_61: retention_family 61 . +global_interpretation retention_62: retention_family 62 . +global_interpretation retention_63: retention_family 63 . +global_interpretation retention_64: retention_family 64 . + +lemma retention_64_cancellation: + shows \retention_64.retention_attr + (retention_set_right n (retention_64.retention_op R)) = + retention_64.retention_attr (retention_64.retention_op R)\ + by simp + +ML\ + AutoLocality_C1_Locale_Retention.sample 64 \<^theory> \<^context> +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test3.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test3.thy new file mode 100644 index 00000000..c504fb7c --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test3.thy @@ -0,0 +1,212 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test3 + imports Autogen.AutoLocality +begin +(*>*) + +text\Regression suite for reworked AutoLocality: on-the-fly cancellation via the default-on +\<^verbatim>\locality_cancel\ simprocs, ML-tactic lemma generation, and the absence of the old quadratic +pre-generation. Everything here is self-contained on toy records.\ + +section\A record whose operations do not trivially reduce to field updates\ + +text\\<^verbatim>\opaque_*\ operations have bodies that touch the field non-trivially, so cancellation +genuinely exercises the definition-unfolding prover rather than bottoming out in record_simps.\ + +datatype_record three = + fa :: nat + fb :: nat + fc :: nat + +locality_init for three + +definition opaque_a :: \nat \ three \ three\ where + \opaque_a k R \ update_fa (\old. old + k + fa R) R\ +definition opaque_b :: \nat \ three \ three\ where + \opaque_b k R \ update_fb (\old. old * k) R\ +definition set_c :: \nat \ three \ three\ where + \set_c k \ update_fc (\_. k)\ + +definition has_a :: \three \ bool\ where + \has_a R \ fa R > 0\ +definition read_b :: \three \ nat\ where + \read_b R \ fb R\ +\\Attribute with an extra (non-record) argument, record at index 0.\ +definition a_exceeds :: \three \ nat \ bool\ where + \a_exceeds R n \ fa R > n\ +\\Attribute with the record at a non-zero argument index. Its only record argument is at + position 1, so the match index into the list of record positions is 0.\ +definition b_below :: \nat \ three \ bool\ where + \b_below n R \ fb R < n\ + +locality_lemma for three: \opaque_a\ footprint [fa] . +locality_lemma for three: \opaque_b\ footprint [fb] . +locality_lemma for three: \set_c\ footprint [fc] . +locality_lemma for three: \has_a\ footprint [fa] . +locality_lemma for three: \read_b\ footprint [fb] . +locality_lemma for three: \a_exceeds\ footprint [fa] . +locality_lemma for three: \b_below\ [0] footprint [fb] . + +section\E. Generated linear facts are stated correctly\ + +text\The local-action, field-update commutativity and disjointness lemmas for an opaque op are +generated under the expected names and with the expected statements.\ +lemma \opaque_a k R = update_fa (\_. fa (opaque_a k R)) R\ + by (rule AutoLocality_Test3_three_local_op_opaque_a_local) +lemma \opaque_a k (update_fb f R) = update_fb f (opaque_a k R)\ + by (rule AutoLocality_Test3_three_local_op_opaque_a_core) +lemma \fb (opaque_a k R) = fb R\ + by (rule AutoLocality_Test3_three_local_op_opaque_a_disjoint) +lemma \fc (opaque_a k R) = fc R\ + by (rule AutoLocality_Test3_three_local_op_opaque_a_disjoint) + +text\The cancellation 'core' lemma for an attribute against a disjoint field update.\ +lemma \has_a (update_fb f R) = has_a R\ + by (rule AutoLocality_Test3_three_local_attr_has_a_0_core) + +section\The quadratic commutativity bundle is no longer generated\ + +ML\ + \\The old pre-generation produced a record-indexed \<^verbatim>\*_commutativity_facts\ bundle; it must + be absent now.\ + val _ = + (Named_Theorems.check \<^context> ("AutoLocality_Test3_three_commutativity_facts", Position.none); + error "commutativity_facts bundle should not exist") + handle ERROR _ => writeln "OK: no commutativity bundle" +\ + +section\B. On-the-fly cancellation matrix (default-on simproc, plain simp)\ + +text\The simprocs are part of the ambient simpset, so a bare \<^verbatim>\simp\ cancels with no explicit +attribute or lemma list.\ + +lemma \has_a (set_c c X) = has_a X\ by simp +lemma \fa (set_c c X) = fa X\ by simp +lemma \has_a (opaque_a h (set_c c (opaque_b b (opaque_a h2 X)))) = has_a (opaque_a h (opaque_a h2 X))\ + by simp +lemma \has_a (opaque_a h (set_c c (f X))) = has_a (opaque_a h (f X))\ by simp +lemma \a_exceeds (set_c c X) n = a_exceeds X n\ by simp +lemma \b_below n (set_c c X) = b_below n X\ by simp +lemma \has_a (update_fb g (update_fc hf X)) = has_a X\ by simp +lemma \read_b (set_c c (opaque_a h (opaque_b b X))) = read_b (opaque_b b X)\ by simp + +lemma \has_a (opaque_b k R) = has_a R\ + by (simp only: [[locality_autocancellation (three) opaque_b has_a 0]]) + +text\The cancellation also works through \<^verbatim>\simp add: _locality_facts\, the bundle form +that downstream proofs use: the simprocs ride along in the ambient simpset.\ +lemma \has_a (set_c c (opaque_a h X)) = has_a (opaque_a h X)\ + by (simp add: AutoLocality_Test3_three_locality_facts) + +section\C2. On-demand pairwise operation commutativity\ + +text\\<^verbatim>\locality_prove_commutativity\ derives, on demand, the theorem that two registered operations +commute: \<^verbatim>\opA a (opB b R) = opB b (opA a R)\. It is sound by construction (it returns \<^verbatim>\NONE\ rather +than a false theorem): operations with disjoint footprints commute and are proved; operations +sharing a field genuinely do not commute and are declined. Nothing is registered - the caller gets +the theorem back.\ + +ML\ + val ctxt = \<^context> + fun is_some (SOME _) = true | is_some NONE = false + fun prove a b = + locality_prove_commutativity ctxt "three" + (Syntax.read_term ctxt a) (Syntax.read_term ctxt b) + + \\Disjoint footprints: all proved.\ + val _ = if is_some (prove "opaque_a" "opaque_b") then () else error "opaque_a/opaque_b should commute" + val _ = if is_some (prove "opaque_a" "set_c") then () else error "opaque_a/set_c should commute" + val _ = if is_some (prove "opaque_b" "set_c") then () else error "opaque_b/set_c should commute" + \\Order-independent.\ + val _ = if is_some (prove "set_c" "opaque_a") then () else error "set_c/opaque_a should commute" + + \\Soundness: operations sharing a field do NOT commute and must be declined (NONE), not + mis-proved. \<^verbatim>\opaque_a\ with itself shares footprint \<^verbatim>\[fa]\.\ + val _ = case prove "opaque_a" "opaque_a" of + NONE => writeln "OK: footprint-sharing pair correctly declined" + | SOME _ => error "opaque_a/opaque_a was mis-proved (unsound!)" + + \\The derived theorem is exactly the commutativity equation (alpha-checked).\ + val _ = case prove "opaque_a" "set_c" of + SOME thm => + let val expected = Syntax.read_term ctxt + "(opaque_a a_0 (set_c b_0 R) = set_c b_0 (opaque_a a_0 R))" + in if Term.aconv (HOLogic.dest_Trueprop (Thm.prop_of thm), expected) + then writeln "OK: derived commutativity statement matches expectation" + else error "derived commutativity statement is not the expected equation" + end + | NONE => error "opaque_a/set_c should have a derived theorem" +\ + +text\The same derivation is reachable from proof text via the \<^verbatim>\[[locality_autocommutativity (rec) A B]]\ +attribute, which \<^emph>\returns\ the (generalized) commutativity theorem as a fact rather than mutating the +simpset. A bare operation-over-operation goal - which the default-on cancellation simprocs do +\<^emph>\not\ rewrite, since no attribute heads it - then closes by using that fact directly. We exercise all +three fact-position idioms: naming it with \<^theory_text>\lemmas\, resolving with \<^theory_text>\rule\, and feeding it to +\<^theory_text>\simp add:\.\ + +text\Name the produced theorem, then discharge with it.\ +lemmas opaque_a_set_c_commute = [[locality_autocommutativity (three) opaque_a set_c]] +lemma \opaque_a a (set_c c R) = set_c c (opaque_a a R)\ + by (rule opaque_a_set_c_commute) + +text\Or use the anonymous \<^verbatim>\[[\]]\ fact inline, resolving against the goal.\ +lemma \opaque_a a (set_c c R) = set_c c (opaque_a a R)\ + by (rule [[locality_autocommutativity (three) opaque_a set_c]]) + +text\Or hand it to \<^verbatim>\simp add:\ as a rewrite (the schematic generalization is what makes this work).\ +lemma \set_c c (opaque_b b R) = opaque_b b (set_c c R)\ + by (simp add: [[locality_autocommutativity (three) set_c opaque_b]]) + +text\Without the attribute the same bare goal is \<^emph>\not\ closed by a plain \<^verbatim>\simp\ (the cancellation +simprocs only fire under an attribute head), so unfolding is required - confirming the attribute is +what supplies the commutativity rewrite.\ +lemma \opaque_a a (set_c c R) = set_c c (opaque_a a R)\ + by (simp add: opaque_a_def set_c_def) + +text\A footprint-sharing pair genuinely does not commute, so the attribute raises an error rather +than silently adding nothing. We check this at the ML level (an erroring \<^verbatim>\supply\ cannot appear in a +passing theory): applying the attribute to the dummy theorem must raise.\ +ML\ + val _ = + (Raw_Simplifier.map_ss I (Context.Proof \<^context>); \\force evaluation\ + (case locality_prove_commutativity \<^context> "three" + (Syntax.read_term \<^context> "opaque_a") + (Syntax.read_term \<^context> "opaque_a") of + NONE => writeln "OK: attribute would error on the non-commuting pair (NONE from core)" + | SOME _ => error "opaque_a/opaque_a unexpectedly commutes")) +\ + +section\D. Safety: no-op fixpoint, opt-out, idempotent init\ + +text\On a term with nothing to cancel, the simproc must return \<^verbatim>\NONE\ (rather than rewriting and +re-firing forever). We invoke the cancellation procedure directly on a normal-form term — here +\<^verbatim>\has_a (opaque_a h X)\, where the only inner operation shares the attribute's footprint \<^verbatim>\[fa]\ +and so cannot be hoisted — and check it declines. This is the fixpoint property underpinning +the safety of having the simprocs always on.\ + +ML\ + val nothing_to_cancel = + locality_cancellation_simproc "AutoLocality_Test3.three" "has_a" 0 \<^context> + (Thm.cterm_of \<^context> \<^term>\has_a (opaque_a h X)\) + val _ = case nothing_to_cancel of + NONE => writeln "OK: simproc declines a normal-form term (no rewrite, no loop)" + | SOME _ => error "simproc rewrote a normal-form term (possible loop risk)" +\ + +text\\<^verbatim>\locality_no_cancel\ disables the simprocs in scope; with them off, a bare \<^verbatim>\simp\ no longer +cancels, so we finish by unfolding.\ +lemma optout: \has_a (set_c c X) = has_a X\ + supply [[locality_no_cancel]] + by (simp add: has_a_def set_c_def) + +text\\<^verbatim>\locality_init\ is idempotent.\ +locality_init for three +locality_init for three + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Boundaries.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Boundaries.thy new file mode 100644 index 00000000..c9520bd8 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Boundaries.thy @@ -0,0 +1,888 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Boundaries + imports AutoLocality_Test_Common +begin +(*>*) + +section\Naming, manual-proof, merge, and exception boundaries\ + +datatype_record boundary_rec = + ba :: nat + bb :: nat + shadow :: nat + +locality_init for boundary_rec + +definition boundary_attr :: \boundary_rec \ bool\ where + \boundary_attr R \ bb R > 0\ + +definition boundary_rank_attr :: \'a \ boundary_rec \ bool\ where + \boundary_rank_attr x R \ boundary_attr R\ + +definition manual_flip :: \boundary_rec \ boundary_rec\ where + \manual_flip R \ update_ba Suc R\ + +locality_lemma for boundary_rec: \boundary_attr\ footprint [bb] . + +subsection\Manual core certificates via @{verbatim \no_proof\}\ + +locality_lemma for boundary_rec (no_proof): \manual_flip\ footprint [ba] + by (auto simp add: manual_flip_def) + +lemma \boundary_attr (manual_flip R) = boundary_attr R\ + by simp + +ML\ + val ctxt = \<^context> + val _ = AutoLocality_Assert.run_suite "Boundaries/manual-proof" + [ ("manual operation retains all linear certificates", + fn () => AutoLocality_Assert.assert_op_lemmas ctxt + "AutoLocality_Test_Boundaries_boundary_rec" "manual_flip") ] +\ + +subsection\Expanded abbreviations remain semantic registrations\ + +abbreviation boundary_abbreviation_attr :: + \boundary_rec \ nat list\ where + \boundary_abbreviation_attr R \ [bb R] @ [shadow R]\ + +locality_lemma for boundary_rec: + \boundary_abbreviation_attr\ footprint [bb, shadow] . + +lemma boundary_abbreviation_cancel: + shows \boundary_abbreviation_attr (manual_flip R) = + boundary_abbreviation_attr R\ + by simp + +ML\ + val ctxt = \<^context> + val rec_name = + "AutoLocality_Test_Boundaries.boundary_rec" + val pattern = + Syntax.read_term ctxt "boundary_abbreviation_attr" + val entry = + (case select_locality_entry_for_pattern + ctxt rec_name "attribute" pattern of + SOME entry => entry + | NONE => error "Missing abbreviation locality registration") + fun is_abstraction (Abs _) = true + | is_abstraction _ = false + val _ = AutoLocality_Assert.run_suite "Boundaries/abbreviation" + [ ("expanded lambda remains structurally indexed", + fn () => AutoLocality_Assert.check "lambda structural family" + (is_abstraction (#canonical_head (#key entry)))), + ("expanded lambda has no physical dispatcher", + fn () => AutoLocality_Assert.check "semantic-only abbreviation" + (is_none (locality_dispatch_key_of_entry_opt ctxt entry))) ] +\ + +subsection\Custom @{verbatim \update_\} name is not a record field updater\ + +definition update_shadow :: \boundary_rec \ boundary_rec\ where + \update_shadow R \ update_ba Suc R\ + +locality_lemma for boundary_rec: + \AutoLocality_Test_Boundaries.update_shadow\ footprint [ba] . + +lemma \boundary_attr (AutoLocality_Test_Boundaries.update_shadow R) = + boundary_attr R\ + by simp + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_Test_Boundaries.boundary_rec" + val custom = + get_record_locality_entries_for_const rec_name + "AutoLocality_Test_Boundaries.update_shadow" ctxt + val field = + get_record_locality_entries_for_const rec_name + "AutoLocality_Test_Boundaries.boundary_rec.update_shadow" ctxt + val _ = AutoLocality_Assert.run_suite "Boundaries/update-name" + [ ("custom update_-prefixed operation is not a field", + fn () => AutoLocality_Assert.check "custom operation classification" + (case custom of [entry] => not (#field entry) | _ => false)), + ("actual record updater remains a field operation", + fn () => AutoLocality_Assert.check "field operation classification" + (case field of [entry] => #field entry | _ => false)) ] +\ + +subsection\Nested non-reinitializable targets retain local state\ + +context + fixes nested_limit :: nat + assumes nested_limit_positive: \nested_limit > 0\ +begin + +definition nested_nonreinitializable_attr :: + \boundary_rec \ bool\ where + \nested_nonreinitializable_attr R \ bb R < nested_limit\ + +local_setup \Named_Target.revoke_reinitializability\ + +locality_lemma for boundary_rec (no_proof): + \nested_nonreinitializable_attr\ footprint [bb] + by (auto simp add: nested_nonreinitializable_attr_def) + +context + notes [[locality_no_cancel]] +begin + +context + notes [[locality_cancel]] +begin + +lemma nested_nonreinitializable_registration: + shows \nested_limit > 0 \ + nested_nonreinitializable_attr (manual_flip R) = + nested_nonreinitializable_attr R\ + using nested_limit_positive + by simp + +end + +end + +end + +subsection\Dispatcher names preserve qualified operational keys\ + +locale dispatch_collision_B_C = + fixes limit :: nat +begin + +definition f :: \boundary_rec \ bool\ where + \f R \ bb R > limit\ + +locality_lemma for boundary_rec (no_proof): \f\ footprint [bb] + by (auto simp add: f_def) + +end + +locale dispatch_collision_B = + fixes limit :: nat +begin + +definition C_f :: \boundary_rec \ bool\ where + \C_f R \ bb R > limit\ + +locality_lemma for boundary_rec (no_proof): \C_f\ footprint [bb] + by (auto simp add: C_f_def) + +end + +global_interpretation dispatch_collision_left: + dispatch_collision_B_C 0 . + +global_interpretation dispatch_collision_right: + dispatch_collision_B 0 . + +lemma dispatch_collision_left_cancel: + shows \dispatch_collision_left.f (manual_flip R) = + dispatch_collision_left.f R\ + by simp + +lemma dispatch_collision_right_cancel: + shows \dispatch_collision_right.C_f (manual_flip R) = + dispatch_collision_right.C_f R\ + by simp + +ML\ + val ctxt = \<^context> + val background_lthy = + Named_Target.theory_init (Proof_Context.theory_of ctxt) + val rec_name = "AutoLocality_Test_Boundaries.boundary_rec" + + fun require_entry label pattern = + (case select_locality_entry_for_pattern + ctxt rec_name "attribute" pattern of + SOME entry => entry + | NONE => error ("Missing dispatcher-name collision entry " ^ label)) + + val left_entry = + require_entry "left" + \<^term>\dispatch_collision_B_C.f (0 :: nat)\ + val right_entry = + require_entry "right" + \<^term>\dispatch_collision_B.C_f (0 :: nat)\ + val left_key = locality_dispatch_key_of_entry ctxt left_entry + val right_key = locality_dispatch_key_of_entry ctxt right_entry + val left_head = + "AutoLocality_Test_Boundaries.dispatch_collision_B_C.f" + val right_head = + "AutoLocality_Test_Boundaries.dispatch_collision_B.C_f" + + fun old_dispatch_name (key : locality_dispatch_key) = + string_to_identifier (#head_name key) ^ "_locality_dispatch_" + ^ Int.toString (#arity key) ^ "_simproc" + + val left_generated_name = + locality_dispatch_simproc_name left_key + val right_generated_name = + locality_dispatch_simproc_name right_key + + fun has_relative_name relative_name full_name = + let + val relative_components = Long_Name.explode relative_name + val full_components = Long_Name.explode full_name + val prefix_count = + length full_components - length relative_components + in + prefix_count >= 0 + andalso drop prefix_count full_components = relative_components + end + + val inventory = + LocalityDispatcherInventory.get (Context.Proof ctxt) + + fun require_inventory_entry label key = + (case LocalityDispatchKeyTable.lookup inventory key of + SOME entry => entry + | _ => error ("Missing dispatcher-name inventory entry " ^ label)) + + val left_inventory_entry = + require_inventory_entry "left" left_key + val right_inventory_entry = + require_inventory_entry "right" right_key + val left_alias = #alias left_inventory_entry + val right_alias = #alias right_inventory_entry + val left_source_name = #source_name left_inventory_entry + val right_source_name = #source_name right_inventory_entry + val family_inventory_entries = + LocalityDispatchKeyTable.dest inventory + |> filter (fn (key, _) => + locality_dispatch_key_eq (key, left_key) + orelse locality_dispatch_key_eq (key, right_key)) + val inventory_names = + [left_alias, right_alias] + val checked_names = + map (fn name => + #1 (Simplifier.check_simproc ctxt (name, Position.none))) + inventory_names + val raw_simprocs = + Raw_Simplifier.simpset_of ctxt + |> Raw_Simplifier.dest_ss + |> #simprocs + fun raw_count source_name = + raw_simprocs + |> filter (fn (name, _) => name = source_name) + |> length + val family_raw_count = + raw_simprocs + |> filter (fn (name, _) => + has_relative_name left_generated_name name + orelse has_relative_name right_generated_name name) + |> length + + val near_limit_size = 20000 + val near_limit_prefix = + String.implode + (replicate (near_limit_size - 1) #"q") + val near_limit_component0 = near_limit_prefix ^ "a" + val near_limit_component1 = near_limit_prefix ^ "b" + + fun near_limit_key component : locality_dispatch_key = + { head_name = + Long_Name.implode ["Synthetic", component, "f"], + arity = 2 } + + val near_limit_key0 = + near_limit_key near_limit_component0 + val near_limit_key1 = + near_limit_key near_limit_component1 + val near_limit_binding0 = + locality_dispatch_simproc_binding near_limit_key0 + val near_limit_binding1 = + locality_dispatch_simproc_binding near_limit_key1 + val near_limit_name0 = + locality_dispatch_simproc_name near_limit_key0 + val near_limit_name1 = + locality_dispatch_simproc_name near_limit_key1 + val near_limit_components0 = + Long_Name.explode near_limit_name0 + val near_limit_components1 = + Long_Name.explode near_limit_name1 + val near_limit_spec_name0 = + #full_name (Binding.name_spec [] [] near_limit_binding0) + val near_limit_spec_name1 = + #full_name (Binding.name_spec [] [] near_limit_binding1) + val near_limit_full_name0 = + Local_Theory.full_name background_lthy near_limit_binding0 + val near_limit_full_name1 = + Local_Theory.full_name background_lthy near_limit_binding1 + val near_limit_chunks0 = + Long_Name.make_chunks near_limit_full_name0 + val near_limit_chunks1 = + Long_Name.make_chunks near_limit_full_name1 + val near_limit_payload_count0 = + near_limit_components0 + |> filter (String.isPrefix "c1_p") + |> length + val near_limit_payload_count1 = + near_limit_components1 + |> filter (String.isPrefix "c1_p") + |> length + + val _ = AutoLocality_Assert.run_suite + "Boundaries/dispatcher-name-encoding" + [ ("fixture has the intended distinct qualified heads", + fn () => AutoLocality_Assert.check "qualified collision heads" + (#head_name left_key = left_head + andalso #head_name right_key = right_head + andalso #arity left_key = 2 + andalso #arity right_key = 2)), + ("the former flattened physical names collide", + fn () => AutoLocality_Assert.check "old physical-name collision" + (old_dispatch_name left_key = + old_dispatch_name right_key)), + ("semantic and dispatch keys remain distinct", + fn () => AutoLocality_Assert.check "distinct registrations" + (not (locality_operational_key_eq + (#key left_entry, #key right_entry)) + andalso not (locality_dispatch_key_eq + (left_key, right_key)))), + ("complete-key encodings generate distinct names", + fn () => AutoLocality_Assert.check "injective dispatcher names" + (left_generated_name <> right_generated_name)), + ("near-limit keys split into bounded binding components", + fn () => AutoLocality_Assert.check "bounded dispatcher binding" + (size near_limit_component0 = near_limit_size + andalso size near_limit_component1 = near_limit_size + andalso size near_limit_name0 > 32768 + andalso size near_limit_name1 > 32768 + andalso near_limit_payload_count0 > 1 + andalso near_limit_payload_count1 > 1 + andalso forall + (fn component => size component < 32768) + (near_limit_components0 @ near_limit_components1) + andalso forall Symbol_Pos.is_identifier + (near_limit_components0 @ near_limit_components1) + andalso forall (fn (_, mandatory) => mandatory) + (Binding.path_of near_limit_binding0 + @ Binding.path_of near_limit_binding1) + andalso Long_Name.implode_chunks near_limit_chunks0 = + near_limit_full_name0 + andalso Long_Name.implode_chunks near_limit_chunks1 = + near_limit_full_name1)), + ("near-limit last-byte variants retain distinct bindings", + fn () => AutoLocality_Assert.check "injective bounded binding" + (near_limit_component0 <> near_limit_component1 + andalso near_limit_binding0 <> near_limit_binding1 + andalso near_limit_name0 <> near_limit_name1 + andalso near_limit_spec_name0 = near_limit_name0 + andalso near_limit_spec_name1 = near_limit_name1 + andalso Binding.long_name_of near_limit_binding0 = + near_limit_name0 + andalso Binding.long_name_of near_limit_binding1 = + near_limit_name1 + andalso near_limit_full_name0 <> near_limit_full_name1 + andalso has_relative_name near_limit_name0 + near_limit_full_name0 + andalso has_relative_name near_limit_name1 + near_limit_full_name1)), + ("both families retain one local inventory identity", + fn () => AutoLocality_Assert.check "two inventory identities" + (length family_inventory_entries = 2 + andalso has_relative_name + left_generated_name left_alias + andalso has_relative_name + right_generated_name right_alias + andalso left_alias <> right_alias)), + ("both representative names resolve with one raw dispatcher each", + fn () => AutoLocality_Assert.check "two raw dispatchers" + (checked_names = inventory_names + andalso raw_count left_source_name = 1 + andalso raw_count right_source_name = 1 + andalso family_raw_count = 2)) ] +\ + +subsection\Lossy public-name collisions are rejected before proof setup\ + +definition policy'a :: \boundary_rec \ boundary_rec\ where + \policy'a R \ update_ba Suc R\ + +definition policyPa :: \boundary_rec \ boundary_rec\ where + \policyPa R \ update_bb Suc R\ + +locality_lemma for boundary_rec: \policy'a\ footprint [ba] . + +ML\ + val ctxt = \<^context> + val _ = AutoLocality_Assert.run_suite "Boundaries/public-name-collision" + [ ("distinct typed patterns with one generated id are rejected", + fn () => AutoLocality_Assert.assert_raises "generated public id collision" + (fn () => + state_locality NONE "boundary_rec" "policyPa" ["bb"] true 0 ctxt)) ] +\ + +subsection\Conflicting context merges fail loudly\ + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_Test_Boundaries.boundary_rec" + val entry = + hd (get_record_locality_entries_for_const rec_name + "AutoLocality_Test_Boundaries.policy'a" ctxt) + val conflict : locality_entry = + { key = #key entry, + const_name = #const_name entry, + pattern = #pattern entry, + footprint = ["bb"], + field = #field entry, + core_thms = #core_thms entry, + disjoint_thms = #disjoint_thms entry, + local_thm = #local_thm entry } + + fun polymorphic_var type_name var_name = + Var ((var_name, 0), + TVar ((type_name, 0), \<^sort>\type\)) + + fun reflexive_certificate term = + Thm.reflexive (Thm.cterm_of ctxt term) + + fun synthetic_entry const_name pattern core_thms = + make_locality_entry rec_name Locality_Attribute + const_name pattern [] ["ba"] 0 0 false + core_thms [] NONE + + val alpha_pattern0 = polymorphic_var "'alpha" "pattern_x" + val alpha_pattern1 = polymorphic_var "'beta" "pattern_y" + val alpha_entry0 = + synthetic_entry "alpha_bundle" alpha_pattern0 + [reflexive_certificate alpha_pattern0] + val alpha_entry1 = + synthetic_entry "alpha_bundle" alpha_pattern1 + [reflexive_certificate alpha_pattern1] + val sharing_conflict = + synthetic_entry "alpha_bundle" alpha_pattern1 + [reflexive_certificate + (polymorphic_var "'beta" "certificate_z")] + + fun hidden_prop binder_name reflexive = + let + val bound = Free (binder_name, \<^typ>\nat\) + val rhs = + if reflexive then bound else \<^term>\0 :: nat\ + val body = + HOLogic.mk_Trueprop (HOLogic.mk_eq (bound, rhs)) + in + Logic.all_const \<^typ>\nat\ $ + Term.lambda_name (binder_name, bound) body + end + + val hidden_conclusion = \<^prop>\True\ + + fun hidden_only_certificate (binder0, binder1) = + let + val prop0 = hidden_prop binder0 true + val prop1 = hidden_prop binder1 false + val implication = + Logic.mk_implies + (prop0, Logic.mk_implies (prop1, hidden_conclusion)) + val implication_thm = + Thm.assume (Thm.cterm_of ctxt implication) + val prop0_thm = + Thm.assume (Thm.cterm_of ctxt prop0) + val prop1_thm = + Thm.assume (Thm.cterm_of ctxt prop1) + in + Thm.implies_elim implication_thm prop0_thm + |> (fn thm => Thm.implies_elim thm prop1_thm) + end + + val hidden_pattern = \<^term>\True\ + val hidden_certificate0 = + hidden_only_certificate + ("hidden_zeta", "hidden_alpha") + val hidden_certificate1 = + hidden_only_certificate + ("hidden_beta", "hidden_omega") + val hidden_hyps0 = Thm.hyps_of hidden_certificate0 + val hidden_hyps1 = Thm.hyps_of hidden_certificate1 + + fun has_no_schematic_variables terms = + null (fold Term.add_vars terms []) + andalso null (fold Term.add_tvars terms []) + + val hidden_entry0 = + synthetic_entry "hidden_bundle" hidden_pattern + [hidden_certificate0] + val hidden_entry1 = + synthetic_entry "hidden_bundle" hidden_pattern + [hidden_certificate1] + + fun merge_entries (entry0, entry1) = + merge_locality_entry_lists ([entry0], [entry1]) + + fun assert_single_merge expected entries = + AutoLocality_Assert.check "one compatible merged bundle" + (case entries of + [merged] => + locality_entry_certificate_fingerprint_ord + (locality_entry_certificate_fingerprint expected, + locality_entry_certificate_fingerprint merged) = EQUAL + | _ => false) + + val _ = AutoLocality_Assert.run_suite "Boundaries/strict-merge" + [ ("hidden fixture uses closed alpha-renamed assumptions", + fn () => AutoLocality_Assert.check "hidden-binder fixture" + (Term.aconv + (Thm.full_prop_of hidden_certificate0, hidden_conclusion) + andalso Term.aconv + (Thm.full_prop_of hidden_certificate1, hidden_conclusion) + andalso not (null hidden_hyps0) + andalso has_no_schematic_variables hidden_hyps0 + andalso has_no_schematic_variables hidden_hyps1 + andalso eq_set Term.aconv (hidden_hyps0, hidden_hyps1) + andalso not (eq_set (op =) (hidden_hyps0, hidden_hyps1)))), + ("alpha-renamed pattern and certificates merge left-first", + fn () => assert_single_merge + alpha_entry0 + (merge_entries (alpha_entry0, alpha_entry1))), + ("alpha-renamed pattern and certificates merge right-first", + fn () => assert_single_merge + alpha_entry0 + (merge_entries (alpha_entry1, alpha_entry0))), + ("hidden-hypothesis binder renaming merges left-first", + fn () => assert_single_merge + hidden_entry0 + (merge_entries (hidden_entry0, hidden_entry1))), + ("hidden-hypothesis binder renaming merges right-first", + fn () => assert_single_merge + hidden_entry0 + (merge_entries (hidden_entry1, hidden_entry0))), + ("changed pattern-certificate sharing rejects left-first", + fn () => AutoLocality_Assert.assert_raises "sharing conflict" + (fn () => merge_entries (alpha_entry0, sharing_conflict))), + ("changed pattern-certificate sharing rejects right-first", + fn () => AutoLocality_Assert.assert_raises "sharing conflict" + (fn () => merge_entries (sharing_conflict, alpha_entry0))), + ("same typed slot with a different footprint rejects left-first", + fn () => AutoLocality_Assert.assert_raises "conflicting merge" + (fn () => merge_entries (entry, conflict))), + ("same typed slot with a different footprint rejects right-first", + fn () => AutoLocality_Assert.assert_raises "conflicting merge" + (fn () => merge_entries (conflict, entry))) ] +\ + +subsection\Physical dispatcher origins merge strictly\ + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_Test_Boundaries.boundary_rec" + val source_entry = + the (select_locality_entry_for_pattern ctxt rec_name "attribute" + \<^term>\boundary_attr\) + val dispatch_key = + locality_dispatch_key_of_entry ctxt source_entry + val origin = stamp () + val other_origin = stamp () + + fun singleton key origin source_name alias = + LocalityDispatchKeyTable.update + (key, + { origin = origin, + source_name = source_name, + alias = alias } : + locality_dispatcher_inventory_entry) + LocalityDispatchKeyTable.empty + + val same_origin_left = + singleton dispatch_key origin "source" "alias.left" + val same_origin_right = + singleton dispatch_key origin "source" "alias.right" + val merged_same_origin_lr = + merge_locality_dispatcher_inventories + (same_origin_left, same_origin_right) + val merged_same_origin_rl = + merge_locality_dispatcher_inventories + (same_origin_right, same_origin_left) + fun merged_alias inventory = + (case LocalityDispatchKeyTable.lookup inventory dispatch_key of + SOME entry => #alias entry + | NONE => "") + val different_origin = + singleton dispatch_key other_origin "source" "alias.right" + + val _ = AutoLocality_Assert.run_suite + "Boundaries/dispatcher-origin-merge" + [ ("same-origin aliases choose one deterministic representative", + fn () => AutoLocality_Assert.check + "same-origin representative alias" + (merged_alias merged_same_origin_lr = "alias.left" + andalso + merged_alias merged_same_origin_rl = "alias.left")), + ("independent origins reject left-first", + fn () => AutoLocality_Assert.assert_raises + "independent dispatcher origin" + (fn () => merge_locality_dispatcher_inventories + (same_origin_left, different_origin))), + ("independent origins reject right-first", + fn () => AutoLocality_Assert.assert_raises + "independent dispatcher origin" + (fn () => merge_locality_dispatcher_inventories + (different_origin, same_origin_left))) ] +\ + +subsection\Semantic replay is independent of dispatcher inventory\ + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_Test_Boundaries.boundary_rec" + val source_entry = + the (select_locality_entry_for_pattern ctxt rec_name "attribute" + \<^term>\boundary_attr\) + val probe_rec_name = rec_name ^ ".Semantic_Replay_Probe" + val probe_entry = + make_locality_entry probe_rec_name + (locality_entry_kind source_entry) + (#const_name source_entry) (#pattern source_entry) + (locality_entry_flexible_prefix source_entry) + (#footprint source_entry) + (locality_entry_args source_entry) + (locality_entry_idx source_entry) + (#field source_entry) + (#core_thms source_entry) + (#disjoint_thms source_entry) + (#local_thm source_entry) + val descriptor = locality_entry_descriptor probe_entry + val facts = locality_entry_fact_bundle ctxt probe_entry + val (run_id, counted_ctxt) = + AutoLocality_Instrumentation.start_run ctxt + val probe_context = + Context.Proof counted_ctxt + |> LocalityDispatcherInventory.put + LocalityDispatchKeyTable.empty + val replayed_context = + replay_locality_registration probe_rec_name descriptor facts + Morphism.identity probe_context + val replayed_entries = + get_record_locality_entries_generic + probe_rec_name replayed_context + val indexed_keys = + Symtab.lookup + (#records (LocalitySecondaryIndex.get replayed_context)) + probe_rec_name + |> Option.map LocalityOperationalKeyTable.keys + |> the_default [] + val snapshot = + (case AutoLocality_Instrumentation.freeze_run run_id of + SOME value => value + | NONE => error "Semantic-replay run did not freeze") + val _ = + if AutoLocality_Instrumentation.drop_run run_id then () + else error "Semantic-replay run did not drop" + fun counter name = + AutoLocality_Instrumentation.snapshot_counter snapshot name + val _ = AutoLocality_Assert.run_suite + "Boundaries/semantic-dispatch-separation" + [ ("semantic replay succeeds with an empty dispatcher inventory", + fn () => AutoLocality_Assert.check "independent semantic replay" + (case replayed_entries of + [entry] => + locality_operational_key_eq + (#key entry, #key probe_entry) + | _ => false)), + ("semantic replay updates only semantic and secondary data", + fn () => AutoLocality_Assert.check "separate physical inventory" + (LocalityDispatchKeyTable.is_empty + (LocalityDispatcherInventory.get replayed_context) + andalso indexed_keys = [#key probe_entry])), + ("semantic replay records one insertion", + fn () => AutoLocality_Assert.check "semantic replay counters" + (counter + AutoLocality_Instrumentation.Lifecycle_Semantic_Insertions = 1 + andalso counter + AutoLocality_Instrumentation.Lifecycle_Replays = 0 + andalso counter AutoLocality_Instrumentation.Index_Nodes = 5 + andalso counter + AutoLocality_Instrumentation.Index_Secondary_Insertions = 1)) ] +\ + +subsection\Ranked structural lookup narrows payload loading\ + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_Test_Boundaries.boundary_rec" + val const_name = + "AutoLocality_Test_Boundaries.boundary_rank_attr" + val selected_pattern = + \<^term>\boundary_rank_attr (0 :: nat)\ + val exact_head = Term.head_of selected_pattern + val schematic_pattern = + exact_head $ Var (("rank_argument", 0), \<^typ>\nat\) + val flexible_pattern = selected_pattern + val short_pattern = exact_head + val polymorphic_type = + TVar (("'rank", 0), \<^sort>\type\) + val polymorphic_head = + Const (const_name, + polymorphic_type --> \<^typ>\boundary_rec\ --> + \<^typ>\bool\) + val polymorphic_pattern = + polymorphic_head $ + Var (("rank_polymorphic_argument", 0), polymorphic_type) + val ambiguous_const_name = + "AutoLocality_Test_Boundaries.boundary_rank_attr2" + + fun rank_entry entry_const_name pattern flexible_prefix footprint args idx = + make_locality_entry rec_name Locality_Attribute entry_const_name + pattern flexible_prefix footprint args idx false [] [] NONE + + val selected_entry = + rank_entry const_name selected_pattern [false] ["ba"] 1 0 + val same_rank_decoy = + rank_entry const_name schematic_pattern [false] ["bb"] 1 0 + val flexible_decoy = + rank_entry const_name flexible_pattern [true] ["bb"] 1 0 + val short_decoy = + rank_entry const_name short_pattern [] ["bb"] 2 1 + val polymorphic_decoy = + rank_entry const_name polymorphic_pattern [false] ["bb"] 1 0 + + fun insert_rank_entry entry context = + context + |> RecordLocalityData.map (insert_locality_entry entry) + |> LocalitySecondaryIndex.map + (insert_locality_secondary_key entry) + + val ranked_ctxt = + fold insert_rank_entry + [selected_entry, same_rank_decoy, flexible_decoy, + short_decoy, polymorphic_decoy] + (Context.Proof ctxt) + |> Context.proof_of + val application = + \<^term>\boundary_rank_attr (0 :: nat) R\ + val (head, args) = Term.strip_comb application + val (run_id, counted_ctxt) = + AutoLocality_Instrumentation.start_run ranked_ctxt + val selected_result = + Exn.capture (fn () => + select_locality_entry_kind_with + (locality_direct_counter counted_ctxt) + counted_ctxt rec_name Locality_Attribute head args) () + val inferred_result = + Exn.capture (fn () => + select_locality_entry_for_explicit_pattern_with + locality_no_count + counted_ctxt rec_name Locality_Attribute + selected_pattern NONE) () + val inferred_at_idx_result = + Exn.capture (fn () => + select_locality_entry_for_explicit_pattern_with + locality_no_count + counted_ctxt rec_name Locality_Attribute + selected_pattern (SOME 1)) () + val ambiguous_pattern = + Syntax.read_term ctxt "boundary_rank_attr2 (0 :: nat)" + val ambiguous_entry = + rank_entry ambiguous_const_name ambiguous_pattern [false] ["ba"] 1 0 + val ambiguous_entry_conflict = + rank_entry ambiguous_const_name ambiguous_pattern [false] ["bb"] 2 0 + val ambiguous_ctxt = + fold insert_rank_entry + [ambiguous_entry, ambiguous_entry_conflict] + (Context.Proof ctxt) + |> Context.proof_of + val ambiguous_inference_result = + Exn.capture (fn () => + select_locality_entry_for_explicit_pattern_with + locality_no_count + ambiguous_ctxt rec_name Locality_Attribute + ambiguous_pattern NONE) () + val ambiguity_capture_result = + Exn.capture (fn () => + capture_noninterrupt (fn () => + locality_registry_ambiguity "boundary test")) () + val snapshot = + (case AutoLocality_Instrumentation.freeze_run run_id of + SOME snapshot => snapshot + | NONE => error "Missing ranked lookup snapshot") + val _ = + if AutoLocality_Instrumentation.drop_run run_id then () + else error "Failed to drop ranked lookup instrumentation run" + val selected = Exn.release selected_result + + fun counter counter = + AutoLocality_Instrumentation.snapshot_counter snapshot counter + + val _ = AutoLocality_Assert.run_suite "Boundaries/query-ranking" + [ ("exact rigid longest registration wins over all decoys", + fn () => AutoLocality_Assert.check "ranked registration" + (case selected of + SOME (1, entry) => + #footprint entry = ["ba"] + andalso Term.aconv (#pattern entry, selected_pattern) + | _ => false)), + ("only the exact winner reaches authoritative payload loading", + fn () => AutoLocality_Assert.check "narrowed payload counters" + (counter AutoLocality_Instrumentation.Lookup_Requests = 1 + andalso + counter AutoLocality_Instrumentation.Lookup_Entries_Examined = 1 + andalso + counter AutoLocality_Instrumentation.Lookup_Candidates_Returned = 1 + andalso + counter AutoLocality_Instrumentation.Lookup_Comparisons = 0 + andalso + counter AutoLocality_Instrumentation.Lookup_Specializations = 1 + andalso + counter AutoLocality_Instrumentation.Lookup_Prefix_Alternatives = 2 + andalso + counter AutoLocality_Instrumentation.Lookup_Equality_Attempts = 0)), + ("inferred pattern selection follows the ranked index", + fn () => AutoLocality_Assert.check "ranked inferred registration" + (case inferred_result of + Exn.Res (SOME entry) => + #footprint entry = ["ba"] + andalso Term.aconv (#pattern entry, selected_pattern) + | _ => false)), + ("inferred selection preserves the absolute slot constraint", + fn () => AutoLocality_Assert.check "ranked inferred slot" + (case inferred_at_idx_result of + Exn.Res (SOME entry) => + #footprint entry = ["ba"] + andalso locality_entry_absolute_idx entry = 1 + | _ => false)), + ("registry ambiguity uses a dedicated exception", + fn () => AutoLocality_Assert.check "typed registry ambiguity" + (case ambiguous_inference_result of + Exn.Exn (Locality_Registry_Ambiguity _) => true + | _ => false)), + ("generic exception capture preserves registry ambiguity", + fn () => AutoLocality_Assert.check "captured registry ambiguity" + (case ambiguity_capture_result of + Exn.Exn (Locality_Registry_Ambiguity _) => true + | _ => false)) ] +\ + +subsection\Malformed and nonmatching terms decline quickly\ + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_Test_Boundaries.boundary_rec" + val entry = + the (select_locality_entry_for_pattern ctxt rec_name "attribute" + \<^term>\boundary_attr\) + val unrelated = Thm.cterm_of ctxt \<^term>\True\ + fun declines () = + case locality_cancellation_simproc_for_entry rec_name entry ctxt unrelated of + NONE => true + | SOME _ => false + val batch_declines = + Timeout.apply (Time.fromSeconds 2) + (fn () => List.all (K (declines ())) (1 upto 2000)) () + handle Timeout.TIMEOUT _ => false + val _ = AutoLocality_Assert.run_suite "Boundaries/exception-containment" + [ ("malformed direct invocation returns NONE", + fn () => AutoLocality_Assert.check "malformed decline" (declines ())), + ("2000 nonmatching invocations finish within two seconds", + fn () => AutoLocality_Assert.check "nonmatching workload" + batch_declines) ] +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Cancel.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Cancel.thy new file mode 100644 index 00000000..90b8bbc6 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Cancel.thy @@ -0,0 +1,122 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Cancel + imports AutoLocality_Test_Common +begin +(*>*) + +section\On-the-fly cancellation via the default-on simprocs\ + +text\The reworked AutoLocality discharges cancellations on the fly with per-attribute simprocs that +are part of the ambient simpset. A bare @{verbatim \simp\} therefore cancels operations whose +footprint is disjoint from the attribute, with no explicit lemma list or attribute. This suite +exercises the cancellation matrix: simple, nested, telescoped, through unknown functions, and the +@{verbatim \simp add: _locality_facts\} bundle form that downstream proofs use. It also pins +the fixpoint behaviour (the simproc declines a normal-form term) and the exact rewrite the simproc +synthesises.\ + +datatype_record cel = + ca :: nat + cb :: nat + cc :: nat + +locality_init for cel + +\\Opaque operations: bodies touch their field non-trivially, so cancellation must drive the + definition-unfolding prover rather than bottoming out in record_simps.\ +definition cop_a :: \nat \ cel \ cel\ where + \cop_a k R \ update_ca (\old. old + k + ca R) R\ +definition cop_b :: \nat \ cel \ cel\ where + \cop_b k R \ update_cb (\old. old * k) R\ +definition cset_c :: \nat \ cel \ cel\ where + \cset_c k \ update_cc (\_. k)\ + +definition chas_a :: \cel \ bool\ where + \chas_a R \ ca R > 0\ +definition cread_b :: \cel \ nat\ where + \cread_b R \ cb R\ +\\Attribute with the record at a non-zero argument index (record at position 1).\ +definition cb_below :: \nat \ cel \ bool\ where + \cb_below n R \ cb R < n\ + +locality_lemma for cel: \cop_a\ footprint [ca] . +locality_lemma for cel: \cop_b\ footprint [cb] . +locality_lemma for cel: \cset_c\ footprint [cc] . +locality_lemma for cel: \chas_a\ footprint [ca] . +locality_lemma for cel: \cread_b\ footprint [cb] . +locality_lemma for cel: \cb_below\ [0] footprint [cb] . + +subsection\Cancellation matrix by plain @{term \simp\}\ + +text\Simple: a footprint-disjoint operation under an attribute cancels.\ +lemma \chas_a (cset_c c X) = chas_a X\ by simp +lemma \chas_a (cop_b b X) = chas_a X\ by simp +lemma \cread_b (cop_a a X) = cread_b X\ by simp +lemma \cread_b (cset_c c X) = cread_b X\ by simp + +text\A field selector is itself an attribute, so projections cancel disjoint operations.\ +lemma \ca (cset_c c X) = ca X\ by simp +lemma \cb (cop_a a X) = cb X\ by simp + +text\The record-at-index-1 attribute cancels too.\ +lemma \cb_below n (cset_c c X) = cb_below n X\ by simp +lemma \cb_below n (cop_a a X) = cb_below n X\ by simp + +text\Nested: only the footprint-disjoint operations are hoisted out and cancelled; the +footprint-sharing one is kept.\ +lemma \chas_a (cset_c c (cop_b b (cop_a a X))) = chas_a (cop_a a X)\ by simp +lemma \cread_b (cset_c c (cop_a a (cop_b b X))) = cread_b (cop_b b X)\ by simp + +text\Telescope through bare field updates as well as named operations.\ +lemma \chas_a (update_cb g (update_cc hf X)) = chas_a X\ by simp +lemma \chas_a (cset_c c (update_cb g X)) = chas_a X\ by simp + +text\Cancellation reaches through an unknown function applied to the record.\ +lemma \chas_a (cset_c c (f X)) = chas_a (f X)\ by simp + +subsection\The bundle form @{verbatim \simp add: _locality_facts\}\ + +text\Downstream proofs invoke the record's locality bundle explicitly; the simprocs ride along in +the ambient simpset, so cancellation still happens.\ +lemma \chas_a (cset_c c (cop_a a X)) = chas_a (cop_a a X)\ + by (simp add: AutoLocality_Test_Cancel_cel_locality_facts) + +subsection\Simproc internals: fixpoint declines and exact rewrites\ + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_Test_Cancel.cel" + val _ = AutoLocality_Assert.run_suite "Cancel/simproc" + [ \\A normal-form term (only a footprint-sharing op inside) must be declined: no rewrite, no + loop. This is the safety property underpinning always-on simprocs.\ + ("declines chas_a (cop_a a X)", + fn () => AutoLocality_Assert.assert_simproc_declines ctxt rec_name "chas_a" "chas_a (cop_a a X)"), + ("declines cread_b (cop_b b X)", + fn () => AutoLocality_Assert.assert_simproc_declines ctxt rec_name "cread_b" "cread_b (cop_b b X)"), + \\A cancellable term yields exactly the expected meta-eq right-hand side.\ + ("cancels chas_a (cset_c c X) to chas_a X", + fn () => AutoLocality_Assert.assert_simproc_cancels_to ctxt rec_name "chas_a" "chas_a (cset_c c X)" "chas_a X"), + ("cancels chas_a (cset_c c (cop_a a X)) keeps cop_a", + fn () => AutoLocality_Assert.assert_simproc_cancels_to ctxt rec_name "chas_a" + "chas_a (cset_c c (cop_a a X))" "chas_a (cop_a a X)") ] +\ + +subsection\Cancellation matrix as an ML suite (parsed-goal form)\ + +ML\ + val ctxt = \<^context> + val _ = AutoLocality_Assert.run_suite "Cancel/by-simp" + [ ("simple set", fn () => AutoLocality_Assert.assert_cancels ctxt "chas_a (cset_c c X) = chas_a X"), + ("simple op", fn () => AutoLocality_Assert.assert_cancels ctxt "chas_a (cop_b b X) = chas_a X"), + ("nested keep", fn () => AutoLocality_Assert.assert_cancels ctxt + "chas_a (cset_c c (cop_b b (cop_a a X))) = chas_a (cop_a a X)"), + ("through fn", fn () => AutoLocality_Assert.assert_cancels ctxt "chas_a (cset_c c (f X)) = chas_a (f X)"), + \\A footprint-sharing operation must NOT be cancelled - the equation is not a theorem.\ + ("no spurious cancel", fn () => AutoLocality_Assert.assert_does_not_cancel ctxt "chas_a (cop_a a X) = chas_a X") ] +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Common.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Common.thy new file mode 100644 index 00000000..5c69c88d --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Common.thy @@ -0,0 +1,239 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Common + imports Autogen.AutoLocality +begin +(*>*) + +section\Shared assertion harness for the AutoLocality regression suite\ + +text\The themed @{verbatim \AutoLocality_Test_*\} theories share one ML assertion vocabulary, +collected in the structure @{verbatim \AutoLocality_Assert\}. Every assertion is a thunk +@{verbatim \unit -> unit\} that succeeds silently or raises @{verbatim \ASSERT msg\}; a whole themed +section is run via @{verbatim \run_suite\}, which aggregates the failures of all its tests into a +single @{verbatim \error\} (so one broken case does not mask the rest). The harness only ever calls +into the public AutoLocality ML (the ambient simpset, the named generated facts, and the +cancellation simproc), so the tests exercise exactly what downstream proofs see.\ + +ML\ +structure AutoLocality_Assert = struct + + \\True iff the (parsed) goal closes by the ambient simpset, which includes the default-on + locality cancellation simprocs. This is the workhorse: it is precisely what a downstream + @{verbatim \by simp\} would do.\ + fun cancels ctxt (goal_str : string) : bool = + let val goal = Syntax.read_prop ctxt goal_str in + (Goal.prove ctxt [] [] goal (fn {context, ...} => asm_full_simp_tac context 1); true) + handle ERROR _ => false | THM _ => false + end + + \\As @{verbatim \cancels\}, but bounded by @{verbatim \ms\} milliseconds; a timeout counts as + failure. Used by the performance suite to guard against cancellation blowing up.\ + fun cancels_within ctxt (ms : int) (goal_str : string) : bool = + Timeout.apply (Time.fromMilliseconds (IntInf.fromInt ms)) (fn () => cancels ctxt goal_str) () + handle Timeout.TIMEOUT _ => false + + \\Number of theorems behind a named fact, or @{verbatim \~1\} if the name does not resolve.\ + fun fact_card ctxt (n : string) : int = + (length (Proof_Context.get_thms ctxt n)) handle ERROR _ => ~1 + fun fact_exists ctxt n = fact_card ctxt n >= 0 + + \\Invoke the cancellation simproc directly on a (parsed) term, bypassing the simpset. Used to + test the fixpoint / decline behaviour in isolation.\ + fun simproc_on ctxt rec_name attr_name (term_str : string) : thm option = + locality_cancellation_simproc rec_name attr_name 0 ctxt + (Thm.cterm_of ctxt (Syntax.read_term ctxt term_str)) + + \\Assertion core. @{verbatim \check\} raises @{verbatim \ASSERT\} on failure; @{verbatim \run_guarded\} + captures a thunk's outcome as an optional error message, re-raising interrupts so the harness + never swallows a cancel. @{verbatim \run_suite\} runs a labelled batch and reports pass/fail + counts, collecting every failure into one error.\ + exception ASSERT of string + fun check (label : string) (ok : bool) : unit = + if ok then writeln (" [OK] " ^ label) else raise ASSERT label + + fun run_guarded (f : unit -> unit) : string option = + (case Exn.capture f () of + Exn.Res _ => NONE + | Exn.Exn e => if Exn.is_interrupt e then Exn.reraise e + else SOME (case e of ASSERT m => m | _ => Runtime.exn_message e)) + + fun run_suite (suite_name : string) (tests : (string * (unit -> unit)) list) : unit = + let + fun run (name, body) = Option.map (fn m => name ^ ": " ^ m) (run_guarded body) + val failures = List.mapPartial run tests + val total = length tests + in + if null failures then + writeln ("[PASS] " ^ suite_name ^ ": " ^ Int.toString total ^ "/" ^ Int.toString total) + else + error ("[FAIL] " ^ suite_name ^ ": " ^ Int.toString (total - length failures) ^ "/" + ^ Int.toString total ^ "; failures:\n" ^ cat_lines (map (fn m => " - " ^ m) failures)) + end + + \\High-level assertions used by the themed suites.\ + fun assert_cancels ctxt g = check ("cancels: " ^ g) (cancels ctxt g) + fun assert_does_not_cancel ctxt g = check ("does NOT cancel: " ^ g) (not (cancels ctxt g)) + fun assert_fact ctxt n = check ("fact present: " ^ n) (fact_exists ctxt n) + fun assert_no_fact ctxt n = check ("fact absent: " ^ n) (not (fact_exists ctxt n)) + fun assert_fact_card ctxt n k = + check ("fact " ^ n ^ " has " ^ Int.toString k ^ " thm(s)") (fact_card ctxt n = k) + + \\The three linear lemmas generated for an operation, by record identifier and operation id.\ + fun assert_op_lemmas ctxt rec_id op_id = + (assert_fact ctxt (rec_id ^ "_local_op_" ^ op_id ^ "_local"); + assert_fact ctxt (rec_id ^ "_local_op_" ^ op_id ^ "_core"); + assert_fact ctxt (rec_id ^ "_local_op_" ^ op_id ^ "_disjoint")) + + \\The cancellation 'core' lemma generated for an attribute, by record id, attr id, match index.\ + fun assert_attr_lemmas ctxt rec_id attr_id idx = + assert_fact ctxt (rec_id ^ "_local_attr_" ^ attr_id ^ "_" ^ Int.toString idx ^ "_core") + + \\The OLD quadratic pre-generation produced a @{verbatim \*_commutativity_facts\} bundle. It must + no longer exist.\ + fun assert_no_quadratic ctxt rec_id = + assert_no_fact ctxt (rec_id ^ "_commutativity_facts") + + \\Fixpoint safety: the simproc declines a normal-form term (returns @{verbatim \NONE\}), so it + cannot rewrite-and-refire forever.\ + fun assert_simproc_declines ctxt rn an term_str = + check ("simproc declines: " ^ term_str) + (case simproc_on ctxt rn an term_str of NONE => true | SOME _ => false) + + \\The simproc fires and the right-hand side of the resulting meta-equation is alpha-equivalent + to the parsed @{verbatim \expected_rhs\}. We compare terms with @{verbatim \aconv\}, not printed + strings: @{verbatim \Syntax.string_of_term\} embeds YXML markup, so a string comparison against a + plain literal would spuriously fail.\ + fun assert_simproc_cancels_to ctxt rn an term_str expected_rhs = + check ("simproc cancels " ^ term_str ^ " to " ^ expected_rhs) + (case simproc_on ctxt rn an term_str of + NONE => false + | SOME thm => + (case Thm.prop_of thm of + Const ("Pure.eq", _) $ _ $ rhs => Term.aconv (rhs, Syntax.read_term ctxt expected_rhs) + | _ => false)) + + \\A thunk is expected to raise (non-interrupt) - e.g. an illegal footprint. Interrupts are + re-raised so a user cancel is never mistaken for a passing test.\ + fun assert_raises label (thunk : unit -> 'a) = + check ("raises: " ^ label) + (case Exn.capture thunk () of + Exn.Res _ => false + | Exn.Exn e => if Exn.is_interrupt e then Exn.reraise e else true) + +end +\ + +section\Generative cancellation testing with an independent oracle\ + +text\The hand-written suites cover specific shapes; this engine covers \<^emph>\breadth\. Given a set of +registered attributes and operations (each described by its name, footprint, and a sample argument), +it enumerates every telescope \<^verbatim>\attr (op1 (op2 ... R))\ up to a chosen depth and checks the +cancellation simproc against an \<^emph>\independent\ footprint oracle. + +The oracle is the key to these being real regression tests rather than tautologies: it recomputes, +purely from footprints, exactly which operations should cancel - an operation cancels iff its +footprint is disjoint from the attribute and from every operation that remains between it and the +attribute. It never consults the simproc. A discrepancy (under-cancellation, over-cancellation, a +wrong residual, a decline-where-cancellation-expected, or vice versa) is a genuine failure of one +side or the other. The same generator is instantiated in different contexts (top level, locale, +interpretation, polymorphic) by the matrix theories, turning a handful of operations and attributes +into hundreds of cases per context.\ + +ML\ +structure AutoLocality_Gen = struct + + \\An operation or attribute for generation: its (short or qualified) name, its field footprint, + and a sample argument string for the non-record argument (@{verbatim \""\} if it has none). For + a locale constant the name carries the applied parameter, e.g. @{verbatim \"bigval bump"\}.\ + type item = { name: string, fp: string list, arg: string } + + \\Apply an item to a body term-string: @{verbatim \name arg (body)\} or @{verbatim \name (body)\}.\ + fun apply_str ({name, arg, ...}: item) body = + if arg = "" then name ^ " (" ^ body ^ ")" else name ^ " " ^ arg ^ " (" ^ body ^ ")" + + fun disjoint xs ys = null (inter (op =) xs ys) + + \\ORACLE. Fold the operation telescope outermost-first, maintaining the union of footprints that + are 'blocked' (the attribute's, plus every operation kept so far). An operation cancels iff it + is disjoint from the blocked set; otherwise it stays and extends the blocked set. Returns the + operations that REMAIN, in order. Independent of the simproc.\ + fun oracle_keep attr_fp (ops : item list) = + let + fun go _ [] = [] + | go blocked (item :: rest) = + if disjoint (#fp item) blocked then go blocked rest + else item :: go (union (op =) (#fp item) blocked) rest + in go attr_fp ops end + + \\LHS term-string: @{verbatim \attr (op\<^sub>1 (\ (op\<^sub>n base)))\}, operations outermost-first.\ + fun build_term (attr : item) (ops : item list) (base : string) = + apply_str attr (fold_rev apply_str ops base) + + \\Expected outcome: @{verbatim \NONE\} if the oracle keeps every operation (nothing cancels), + otherwise @{verbatim \SOME rhs\} with the residual term-string.\ + fun expected (attr : item) (ops : item list) (base : string) = + let val keep = oracle_keep (#fp attr) ops + in if length keep = length ops then NONE else SOME (build_term attr keep base) end + + \\Run one generated case against the simproc; @{verbatim \NONE\} on agreement, @{verbatim \SOME msg\} + on any disagreement with the oracle. @{verbatim \attr_key\} is the registered attribute name the + simproc is keyed under (its base name; for a locale attribute this is the bare short name).\ + fun check_case ctxt rec_name attr_key (attr : item) (ops : item list) (base : string) + : string option = + let + val lhs_str = build_term attr ops base + val got = + AutoLocality_Assert.simproc_on ctxt rec_name attr_key lhs_str + val exp = expected attr ops base + in + case (exp, got) of + (NONE, NONE) => NONE + | (NONE, SOME thm) => + SOME (lhs_str ^ ": oracle expects NO cancellation, simproc rewrote to " + ^ Syntax.string_of_term ctxt (Thm.prop_of thm)) + | (SOME _, NONE) => SOME (lhs_str ^ ": oracle expects cancellation, simproc declined") + | (SOME rhs_str, SOME thm) => + (case Thm.prop_of thm of + Const ("Pure.eq", _) $ _ $ rhs => + if Term.aconv (rhs, Syntax.read_term ctxt rhs_str) then NONE + else SOME (lhs_str ^ ": simproc RHS disagrees with oracle (oracle = " ^ rhs_str ^ ")") + | _ => SOME (lhs_str ^ ": simproc result is not a meta-equation")) + end + + \\All operation telescopes over @{verbatim \ops\} of length 1 .. max_depth (with repetition and + order, since order matters to both simproc and oracle).\ + fun telescopes (ops : item list) (max_depth : int) : item list list = + let + fun lists 0 = [[]] + | lists n = maps (fn o1 => map (fn tl => o1 :: tl) (lists (n - 1))) ops + in maps lists (1 upto max_depth) end + + \\Generate the full (attribute x telescope) matrix and check every case against the oracle. + @{verbatim \attr_key_of\} maps an attribute item to the name the simproc is registered under. + Reports pass/fail via @{ML AutoLocality_Assert.run_suite}, so a single failing case names the + exact offending term. Returns the number of cases generated.\ + fun run_matrix suite_name ctxt rec_name attr_key_of (attrs : item list) (ops : item list) + (max_depth : int) (base : string) : int = + let + val tels = telescopes ops max_depth + val cases = maps (fn a => map (fn t => (a, t)) tels) attrs + val tests = + map (fn (a, t) => + (build_term a t base, + fn () => + case check_case ctxt rec_name (attr_key_of a) a t base of + NONE => () | SOME m => raise AutoLocality_Assert.ASSERT m)) + cases + val _ = AutoLocality_Assert.run_suite + (suite_name ^ " (" ^ Int.toString (length cases) ^ " cases)") tests + in length cases end + +end +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Contexts.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Contexts.thy new file mode 100644 index 00000000..2369cda7 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Contexts.thy @@ -0,0 +1,309 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Contexts + imports AutoLocality_Test_Common +begin +(*>*) + +section\Context transport, overloading, and repeated record arguments\ + +datatype_record ctx = + xa :: nat + xb :: nat + xc :: nat + +locality_init for ctx + +definition set_a :: \nat \ ctx \ ctx\ where + \set_a n \ update_xa (\_. n)\ +definition set_b :: \nat \ ctx \ ctx\ where + \set_b n \ update_xb (\_. n)\ +definition set_c :: \nat \ ctx \ ctx\ where + \set_c n \ update_xc (\_. n)\ + +locality_lemma for ctx: \set_a\ footprint [xa] . +locality_lemma for ctx: \set_b\ footprint [xb] . +locality_lemma for ctx: \set_c\ footprint [xc] . + +subsection\Explicit sublocale transport and nested locales\ + +locale parent_ctx = + fixes bump :: \nat \ nat\ +begin + +definition parent_attr :: \ctx \ bool\ where + \parent_attr R \ bump (xa R) > 10\ + +definition parent_op :: \ctx \ ctx\ where + \parent_op R \ update_xa bump R\ + +end + +context parent_ctx begin + +locality_lemma for ctx: \parent_attr\ footprint [xa] . +locality_lemma for ctx: \parent_op\ footprint [xa] . + +lemma \parent_attr (set_c n R) = parent_attr R\ + by simp + +end + +locale child_ctx = + fixes bump :: \nat \ nat\ + and shift :: \nat \ nat\ +begin + +definition child_attr :: \ctx \ bool\ where + \child_attr R \ shift (xb R) > 20\ + +definition child_op :: \ctx \ ctx\ where + \child_op R \ update_xb shift R\ + +end + +sublocale child_ctx \ parent_ctx bump . + +context child_ctx begin + +locality_lemma for ctx: \child_attr\ footprint [xb] . +locality_lemma for ctx: \child_op\ footprint [xb] . + +lemma \parent_attr (set_c n (child_op R)) = parent_attr (child_op R)\ + by simp + +lemma \child_attr (set_c n (parent_op R)) = child_attr (parent_op R)\ + by simp + +end + +locale grandchild_ctx = child_ctx bump shift + for bump shift + + fixes twist :: \nat \ nat\ +begin + +definition grandchild_op :: \ctx \ ctx\ where + \grandchild_op R \ update_xc twist R\ + +end + +context grandchild_ctx begin + +locality_lemma for ctx: \grandchild_op\ footprint [xc] . + +lemma \parent_attr (grandchild_op (child_op R)) = parent_attr (child_op R)\ + by simp + +lemma \child_attr (grandchild_op (parent_op R)) = child_attr (parent_op R)\ + by simp + +end + +global_interpretation gc: grandchild_ctx Suc \\n. n + 2\ \\n. n * 2\ . + +lemma \gc.parent_attr (set_c n (gc.child_op R)) = gc.parent_attr (gc.child_op R)\ + by simp + +lemma \gc.child_attr (gc.grandchild_op (gc.parent_op R)) = + gc.child_attr (gc.parent_op R)\ + by simp + +subsection\Locale assumptions in transported certificates\ + +locale assumption_ctx = + fixes projection :: \ctx \ nat\ + assumes projection_eq: \projection = xa\ +begin + +definition assumed_attr :: \ctx \ bool\ where + \assumed_attr R \ projection R > 0\ + +end + +context assumption_ctx begin + +text\The declared footprint is sound only under +@{thm projection_eq}: without that assumption an arbitrary projection could +observe every field. The generated certificate therefore carries a locale +hypothesis that standard declaration transport must preserve and discharge +during interpretation.\ + +lemma assumed_attr_update_xb: + shows \assumed_attr (update_xb f R) = assumed_attr R\ + unfolding assumed_attr_def + using projection_eq + by simp + +lemma assumed_attr_update_xc: + shows \assumed_attr (update_xc f R) = assumed_attr R\ + unfolding assumed_attr_def + using projection_eq + by simp + +locality_lemma for ctx (no_proof): + \assumed_attr\ footprint [xa] + by (auto simp only: + assumed_attr_update_xb assumed_attr_update_xc) + +lemma assumption_dependent_certificate_local: + shows \assumed_attr (set_c n R) = assumed_attr R\ + by (simp only: [[locality_cancel]]) + +end + +global_interpretation assumed_xa: assumption_ctx xa + by standard simp + +lemma assumption_dependent_certificate_interpreted: + shows \assumed_xa.assumed_attr (set_c n R) = + assumed_xa.assumed_attr R\ + by (simp only: [[locality_cancel]]) + +subsection\Independent locales with colliding base names\ + +locale left_ctx = + fixes adjust :: \nat \ nat\ +begin + +definition view :: \ctx \ bool\ where + \view R \ adjust (xa R) > 0\ + +end + +locale right_ctx = + fixes adjust :: \nat \ nat\ +begin + +definition view :: \ctx \ bool\ where + \view R \ adjust (xb R) > 0\ + +end + +context left_ctx begin +locality_lemma for ctx: \view\ footprint [xa] . +end + +context right_ctx begin +locality_lemma for ctx: \view\ footprint [xb] . +end + +global_interpretation lc: left_ctx Suc . +global_interpretation rc: right_ctx Suc . + +lemma \lc.view (set_c n R) = lc.view R\ + by simp + +lemma \rc.view (set_a n R) = rc.view R\ + by simp + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_Test_Contexts.ctx" + val left_entry = + select_locality_entry_for_pattern ctxt rec_name "attribute" + \<^term>\left_ctx.view Suc\ + val right_entry = + select_locality_entry_for_pattern ctxt rec_name "attribute" + \<^term>\right_ctx.view Suc\ + val _ = AutoLocality_Assert.run_suite "Contexts/colliding-locale-base-names" + [ ("left typed pattern selects its entry", + fn () => AutoLocality_Assert.check "left entry" + (case left_entry of SOME entry => #footprint entry = ["xa"] | NONE => false)), + ("right typed pattern selects its entry", + fn () => AutoLocality_Assert.check "right entry" + (case right_entry of SOME entry => #footprint entry = ["xb"] | NONE => false)) ] +\ + +subsection\Ad-hoc overloading resolves to typed concrete constants\ + +consts overloaded_attr :: \'a \ bool\ +consts overloaded_op :: \'a \ 'a\ + +definition concrete_attr :: \ctx \ bool\ where + \concrete_attr R \ xa R > 0\ + +definition concrete_op :: \ctx \ ctx\ where + \concrete_op R \ update_xa Suc R\ + +adhoc_overloading overloaded_attr \ concrete_attr +adhoc_overloading overloaded_op \ concrete_op + +locality_lemma for ctx: \overloaded_attr :: ctx \ bool\ footprint [xa] . +locality_lemma for ctx: \overloaded_op :: ctx \ ctx\ footprint [xa] . + +lemma \overloaded_attr (set_c n R :: ctx) = overloaded_attr R\ + by simp + +lemma \xb (overloaded_op R :: ctx) = xb R\ + by simp + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_Test_Contexts.ctx" + val attr_entry = + select_locality_entry_for_pattern ctxt rec_name "attribute" + \<^term>\overloaded_attr :: ctx \ bool\ + val op_entry = + select_locality_entry_for_pattern ctxt rec_name "operation" + \<^term>\overloaded_op :: ctx \ ctx\ + val _ = AutoLocality_Assert.run_suite "Contexts/adhoc-overloading" + [ ("attribute resolves to its concrete constant", + fn () => AutoLocality_Assert.check "concrete overloaded attribute" + (case attr_entry of + SOME entry => #const_name entry = "AutoLocality_Test_Contexts.concrete_attr" + | NONE => false)), + ("operation resolves to its concrete constant", + fn () => AutoLocality_Assert.check "concrete overloaded operation" + (case op_entry of + SOME entry => #const_name entry = "AutoLocality_Test_Contexts.concrete_op" + | NONE => false)) ] +\ + +subsection\One attribute registered at two record argument positions\ + +definition pair_attr :: \ctx \ ctx \ bool\ where + \pair_attr L R \ xa L < xb R\ + +locality_lemma for ctx: \pair_attr\ [0] footprint [xa] . +locality_lemma for ctx: \pair_attr\ [1] footprint [xb] . + +lemma \pair_attr (set_c n L) R = pair_attr L R\ + by simp + +lemma \pair_attr L (set_a n R) = pair_attr L R\ + by simp + +lemma \pair_attr (set_b n L) (set_c m R) = pair_attr L R\ + by simp + +lemma \pair_attr (set_c n L) (set_c m R) = pair_attr L R\ + by simp + +lemma \pair_attr (set_c n L) R = pair_attr L R\ + by (simp only: [[locality_autocancellation (ctx) set_c pair_attr 0]]) + +lemma \pair_attr L (set_a n R) = pair_attr L R\ + by (simp only: [[locality_autocancellation (ctx) set_a pair_attr 1]]) + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_Test_Contexts.ctx" + val entries = + get_record_locality_entries_for_const rec_name + "AutoLocality_Test_Contexts.pair_attr" ctxt + |> filter (fn entry => locality_entry_kind entry = Locality_Attribute) + val slots = + map (fn entry => (locality_entry_idx entry, #footprint entry)) entries + val _ = AutoLocality_Assert.run_suite "Contexts/repeated-record-arguments" + [ ("both record positions are registered", + fn () => AutoLocality_Assert.check "pair_attr slots" + (member (op =) slots (0, ["xa"]) andalso + member (op =) slots (1, ["xb"]) andalso + length entries = 2)) ] +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Diamond.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Diamond.thy new file mode 100644 index 00000000..a3c736f3 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Diamond.thy @@ -0,0 +1,120 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Diamond + imports AutoLocality_Test_Diamond_Left AutoLocality_Test_Diamond_Right +begin +(*>*) + +section\Import-diamond merge behavior\ + +lemma \diamond_base_attr (diamond_left_op (diamond_base_op R)) = + diamond_base_attr R\ + by simp + +lemma \diamond_left_attr (diamond_right_op (diamond_left_op R)) = + diamond_left_attr R\ + by simp + +lemma \diamond_right_attr (diamond_base_op (diamond_right_op R)) = + diamond_right_attr R\ + by simp + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_Test_Diamond_Base.diamond_rec" + val entries = get_record_locality_entries rec_name ctxt + fun entries_for const_name = + entries |> filter (fn entry => #const_name entry = const_name) + val base_ops = + entries_for "AutoLocality_Test_Diamond_Base.diamond_base_op" + val base_attrs = + entries_for "AutoLocality_Test_Diamond_Base.diamond_base_attr" + val registered_attributes = get_attributes ctxt + val registered_dispatch_keys = + registered_attributes + |> map (locality_dispatch_key_of_entry ctxt o #2) + |> distinct locality_dispatch_key_eq + val inventory = + LocalityDispatcherInventory.get (Context.Proof ctxt) + val installed_locality_dispatchers = + Raw_Simplifier.simpset_of ctxt + |> Raw_Simplifier.dest_ss + |> #simprocs + |> filter + (String.isSubstring "_locality_dispatch_" + o Long_Name.base_name o fst) + val base_dispatchers = + (case base_attrs of + [entry] => + let + val dispatch_key = + locality_dispatch_key_of_entry ctxt entry + val expected = + (case LocalityDispatchKeyTable.lookup + inventory dispatch_key of + SOME entry => #source_name entry + | _ => "") + in + installed_locality_dispatchers + |> filter (fn (name, _) => name = expected) + end + | _ => []) + val base_inventory_entries = + (case base_attrs of + [entry] => + let + val dispatch_key = + locality_dispatch_key_of_entry ctxt entry + in + LocalityDispatchKeyTable.dest inventory + |> filter (fn (key, _) => + locality_dispatch_key_eq (key, dispatch_key)) + end + | _ => []) + val _ = AutoLocality_Assert.run_suite "Diamond/merge" + [ ("common operation is merged into one complete entry", + fn () => AutoLocality_Assert.check "one common operation" + (case base_ops of + [entry] => + not (null (#core_thms entry)) andalso + not (null (#disjoint_thms entry)) andalso + Option.isSome (#local_thm entry) + | _ => false)), + ("common attribute is merged into one complete entry", + fn () => AutoLocality_Assert.check "one common attribute" + (case base_attrs of + [entry] => + not (null (#core_thms entry)) + | _ => false)), + ("both branch-local operation registrations survive", + fn () => AutoLocality_Assert.check "branch operations" + (length (entries_for + "AutoLocality_Test_Diamond_Left.diamond_left_op") = 1 andalso + length (entries_for + "AutoLocality_Test_Diamond_Right.diamond_right_op") = 1)), + ("diamond imports install one raw dispatcher per attribute family", + fn () => AutoLocality_Assert.check "stable family dispatcher identity" + (length installed_locality_dispatchers = + length registered_dispatch_keys)), + ("diamond imports retain one inventory identity per attribute family", + fn () => AutoLocality_Assert.check "stable family inventory identity" + (LocalityDispatchKeyTable.size inventory = + length registered_dispatch_keys)), + ("common-origin base family has one inventory identity", + fn () => AutoLocality_Assert.check "one common inventory identity" + (case base_inventory_entries of + [(_, entry : locality_dispatcher_inventory_entry)] => + #1 (Simplifier.check_simproc + ctxt (#alias entry, Position.none)) = + #alias entry + | _ => false)), + ("common-origin base family has one raw dispatcher", + fn () => AutoLocality_Assert.check "one common raw dispatcher" + (length base_dispatchers = 1)) ] +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Diamond_Base.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Diamond_Base.thy new file mode 100644 index 00000000..4fcb0c0d --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Diamond_Base.thy @@ -0,0 +1,30 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Diamond_Base + imports AutoLocality_Test_Common +begin +(*>*) + +section\Common ancestor for import-diamond tests\ + +datatype_record diamond_rec = + dia :: nat + dib :: nat + dic :: nat + +locality_init for diamond_rec + +definition diamond_base_op :: \diamond_rec \ diamond_rec\ where + \diamond_base_op R \ update_dia Suc R\ + +definition diamond_base_attr :: \diamond_rec \ bool\ where + \diamond_base_attr R \ dib R > 0\ + +locality_lemma for diamond_rec: \diamond_base_op\ footprint [dia] . +locality_lemma for diamond_rec: \diamond_base_attr\ footprint [dib] . + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Diamond_Left.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Diamond_Left.thy new file mode 100644 index 00000000..dbbf5a75 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Diamond_Left.thy @@ -0,0 +1,21 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Diamond_Left + imports AutoLocality_Test_Diamond_Base +begin +(*>*) + +definition diamond_left_op :: \diamond_rec \ diamond_rec\ where + \diamond_left_op R \ update_dic Suc R\ + +definition diamond_left_attr :: \diamond_rec \ bool\ where + \diamond_left_attr R \ dia R > 0\ + +locality_lemma for diamond_rec: \diamond_left_op\ footprint [dic] . +locality_lemma for diamond_rec: \diamond_left_attr\ footprint [dia] . + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Diamond_Right.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Diamond_Right.thy new file mode 100644 index 00000000..1545e312 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Diamond_Right.thy @@ -0,0 +1,21 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Diamond_Right + imports AutoLocality_Test_Diamond_Base +begin +(*>*) + +definition diamond_right_op :: \diamond_rec \ diamond_rec\ where + \diamond_right_op R \ update_dib Suc R\ + +definition diamond_right_attr :: \diamond_rec \ bool\ where + \diamond_right_attr R \ dic R > 0\ + +locality_lemma for diamond_rec: \diamond_right_op\ footprint [dib] . +locality_lemma for diamond_rec: \diamond_right_attr\ footprint [dic] . + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Errors.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Errors.thy new file mode 100644 index 00000000..26fb0fb3 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Errors.thy @@ -0,0 +1,72 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Errors + imports AutoLocality_Test_Common +begin +(*>*) + +section\Error and safety paths\ + +text\This suite pins the negative behaviour: ill-formed @{verbatim \locality_lemma\} invocations are +rejected with an error (rather than silently mis-registering), the @{verbatim \[[locality_no_cancel]]\} +opt-out genuinely disables cancellation in scope, and @{verbatim \locality_init\} is idempotent. The +positive cancellation behaviour is checked in @{theory_text \AutoLocality_Test_Cancel\}; here we make +sure the failure modes are loud and the safety valves work.\ + +datatype_record err = + ea :: nat + eb :: nat + +locality_init for err + +definition eset_a :: \nat \ err \ err\ where + \eset_a k R \ update_ea (\_. k) R\ +definition ehas_a :: \err \ bool\ where + \ehas_a R \ ea R > 0\ + +locality_lemma for err: \eset_a\ footprint [ea] . +locality_lemma for err: \ehas_a\ footprint [ea] . + +subsection\Opt-out: @{verbatim \locality_no_cancel\} disables the simprocs in scope\ + +text\With the simprocs on (the default), cancellation succeeds.\ +lemma \ehas_a (update_eb f R) = ehas_a R\ by simp + +text\With @{verbatim \locality_no_cancel\} supplied, a bare @{verbatim \simp\} no longer cancels, so the +proof must fall back to unfolding the definitions.\ +lemma \ehas_a (update_eb f R) = ehas_a R\ + supply [[locality_no_cancel]] + by (simp add: ehas_a_def) + +subsection\Idempotent initialisation\ + +text\Re-initialising a record is a no-op and must not raise or duplicate data.\ +locality_init for err +locality_init for err + +subsection\Ill-formed invocations are rejected\ + +ML\ + val ctxt = \<^context> + \\Drive the ML entry points directly with bad arguments and require each to raise. We re-raise + interrupts inside @{verbatim \assert_raises\}, so only genuine errors count as passes.\ + val _ = AutoLocality_Assert.run_suite "Errors/rejection" + [ \\A footprint naming a field that does not exist on the record.\ + ("illegal footprint field", + fn () => AutoLocality_Assert.assert_raises "bad field in footprint" + (fn () => state_locality_for_op NONE "err" "eset_a" ["nonexistent"] true ctxt)), + \\A term that is neither an operation nor an attribute on the record.\ + ("non-attribute term", + fn () => AutoLocality_Assert.assert_raises "value is not op/attr on err" + (fn () => state_locality NONE "err" "(0::nat)" ["ea"] true 0 ctxt)), + \\An out-of-range match index for an attribute with a single record argument.\ + ("match index out of range", + fn () => AutoLocality_Assert.assert_raises "match idx 5 out of range" + (fn () => state_locality NONE "err" "ehas_a" ["ea"] true 5 ctxt)) ] +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Linear.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Linear.thy new file mode 100644 index 00000000..34996343 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Linear.thy @@ -0,0 +1,84 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Linear + imports AutoLocality_Test_Common +begin +(*>*) + +section\Linear-lemma generation\ + +text\For each registered operation, @{verbatim \locality_lemma\} generates three linear facts - +the local-action lemma @{verbatim \_local\}, the field-update commutativity @{verbatim \_core\}, and the +disjointness @{verbatim \_disjoint\} - and for each attribute a single cancellation @{verbatim \_core\}. +This suite checks they are generated, under the expected names, with the expected statements and +cardinalities, and that the old quadratic @{verbatim \*_commutativity_facts\} bundle is gone.\ + +datatype_record lin = + la :: nat + lb :: nat + lc :: nat + +locality_init for lin + +definition lset_a :: \nat \ lin \ lin\ where + \lset_a k R \ update_la (\_. k) R\ +\\An operation touching its field non-trivially via the old value, so the local-action lemma + genuinely needs record extensionality.\ +definition lbump_b :: \nat \ lin \ lin\ where + \lbump_b k R \ update_lb (\old. old + k + lb R) R\ +definition lhas_a :: \lin \ bool\ where + \lhas_a R \ la R > 0\ +definition lread_c :: \lin \ nat\ where + \lread_c R \ lc R\ + +locality_lemma for lin: \lset_a\ footprint [la] . +locality_lemma for lin: \lbump_b\ footprint [lb] . +locality_lemma for lin: \lhas_a\ footprint [la] . +locality_lemma for lin: \lread_c\ footprint [lc] . + +subsection\The generated statements are exactly as specified\ + +text\Operation @{verbatim \lbump_b\}: local action, field-update commutativity, and disjointness.\ +lemma \lbump_b k R = update_lb (\_. lb (lbump_b k R)) R\ + by (rule AutoLocality_Test_Linear_lin_local_op_lbump_b_local) +lemma \lbump_b k (update_la f R) = update_la f (lbump_b k R)\ + by (rule AutoLocality_Test_Linear_lin_local_op_lbump_b_core) +lemma \lbump_b k (update_lc f R) = update_lc f (lbump_b k R)\ + by (rule AutoLocality_Test_Linear_lin_local_op_lbump_b_core) +lemma \la (lbump_b k R) = la R\ + by (rule AutoLocality_Test_Linear_lin_local_op_lbump_b_disjoint) +lemma \lc (lbump_b k R) = lc R\ + by (rule AutoLocality_Test_Linear_lin_local_op_lbump_b_disjoint) + +text\Attribute @{verbatim \lhas_a\}: cancellation against a disjoint field update.\ +lemma \lhas_a (update_lb f R) = lhas_a R\ + by (rule AutoLocality_Test_Linear_lin_local_attr_lhas_a_0_core) +lemma \lhas_a (update_lc f R) = lhas_a R\ + by (rule AutoLocality_Test_Linear_lin_local_attr_lhas_a_0_core) + +subsection\Generation metadata: presence, cardinality, no quadratic bundle\ + +ML\ + val ctxt = \<^context> + val rec_id = "AutoLocality_Test_Linear_lin" + val _ = AutoLocality_Assert.run_suite "Linear/generation" + [ ("op lset_a lemmas", fn () => AutoLocality_Assert.assert_op_lemmas ctxt rec_id "lset_a"), + ("op lbump_b lemmas", fn () => AutoLocality_Assert.assert_op_lemmas ctxt rec_id "lbump_b"), + ("attr lhas_a lemma", fn () => AutoLocality_Assert.assert_attr_lemmas ctxt rec_id "lhas_a" 0), + ("attr lread_c lemma", fn () => AutoLocality_Assert.assert_attr_lemmas ctxt rec_id "lread_c" 0), + \\Two disjoint fields -> two field-update commutativity facts and two disjointness facts.\ + ("lbump_b _core card", fn () => AutoLocality_Assert.assert_fact_card ctxt (rec_id ^ "_local_op_lbump_b_core") 2), + ("lbump_b _disjoint card", fn () => AutoLocality_Assert.assert_fact_card ctxt (rec_id ^ "_local_op_lbump_b_disjoint") 2), + ("lbump_b _local card", fn () => AutoLocality_Assert.assert_fact_card ctxt (rec_id ^ "_local_op_lbump_b_local") 1), + \\The attribute cancellation 'core' fact: one per disjoint field of footprint [la], i.e. lb,lc.\ + ("lhas_a _0_core card", fn () => AutoLocality_Assert.assert_fact_card ctxt (rec_id ^ "_local_attr_lhas_a_0_core") 2), + ("no quadratic bundle", fn () => AutoLocality_Assert.assert_no_quadratic ctxt rec_id), + \\The record-wide locality_facts bundle exists and is non-empty.\ + ("locality_facts present", fn () => AutoLocality_Assert.assert_fact ctxt (rec_id ^ "_locality_facts")) ] +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Locale.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Locale.thy new file mode 100644 index 00000000..9e9d95c3 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Locale.thy @@ -0,0 +1,546 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Locale + imports AutoLocality_Test_Common +begin +(*>*) + +section\Locale-defined operations and attributes, and their interpretations\ + +text\An operation or attribute may be defined inside a locale, so that its definition mentions a +locale parameter. @{verbatim \locality_lemma\} must then handle two coordinate systems that ordinary +records never exercise: + + \<^enum> The cancellation simproc's picker runs over the bare constant with the locale parameter applied + explicitly (@{term \bigval bump R\}), so the footprint-database entry must use bare-relative + argument indices, not the abbreviation-relative ones visible in the locale. + + \<^enum> The simproc's match pattern must schematise the leading locale-parameter positions; otherwise it + bakes in the locale's fixed parameter and never matches an interpreted instance. + +Two further usage points are pinned here: + + \<^item> Register a locale constant from a @{command context} re-entry, not from inside the defining + @{command locale} body: the auto-derivation's core proof only closes once the definitions are + fully established. + + \<^item> The cancellable inner operation (@{term \setc\}) is defined at the top level, on the bare record. + Only the parameter-using constants (@{term \bigval\}, @{term \bumpval\}) live in the locale - which + is the representative shape, and side-steps the fact that a parameter-free constant defined + inside a locale is not found by the picker once the locale is left.\ + +datatype_record loc = + oa :: nat + ob :: nat + oc :: nat + +locality_init for loc + +\\A top-level, parameter-free operation on a disjoint field - the thing we cancel against.\ +definition setc :: \nat \ loc \ loc\ where + \setc k \ update_oc (\_. k)\ +locality_lemma for loc: \setc\ footprint [oc] . + +locale scaler = + fixes bump :: \nat \ nat\ +begin + +\\An attribute whose definition mentions the locale parameter @{term \bump\}.\ +definition bigval :: \loc \ bool\ where + \bigval R \ bump (oa R) > 10\ +definition bigval_at :: \nat \ loc \ bool\ where + \bigval_at n R \ bump (oa R) > n\ +\\An operation whose body mentions the locale parameter.\ +definition bumpval :: \loc \ loc\ where + \bumpval R \ update_oa bump R\ + +end + +text\Register from a @{command context} re-entry, with the SHORT names: a short name re-parses to the +bare constant with the locale parameter applied, whereas the qualified name would leave the +parameter unapplied and mis-register the argument indices.\ + +context scaler begin +locality_lemma for loc: \bigval\ footprint [oa] . +locality_lemma for loc: \bigval_at\ footprint [oa] . +locality_lemma for loc: \bumpval\ footprint [oa] . +end + +context scaler begin + +ML\ +structure AutoLocality_Test_Locale_Dispatch_Before = +struct + +val head_name = "AutoLocality_Test_Locale.scaler.bigval" +val ctxt = \<^context> +val inventory_entries = + LocalityDispatcherInventory.get (Context.Proof ctxt) + |> LocalityDispatchKeyTable.dest + |> map (fn (key, entry : locality_dispatcher_inventory_entry) => + (key, #alias entry)) + |> filter (fn (key, _) => #head_name key = head_name) +val (dispatch_key, alias) = + (case inventory_entries of + [(key, alias)] => (key, alias) + | _ => error "Expected one source locale dispatcher inventory entry") +val trigger = locality_dispatch_trigger ctxt dispatch_key +val raw_dispatchers = + Raw_Simplifier.simpset_of ctxt + |> Raw_Simplifier.dest_ss + |> #simprocs + |> filter (fn (_, lhss) => + case lhss of + [lhs] => Term.aconv (lhs, trigger) + | _ => false) +val name = + (case raw_dispatchers of + [(name, _)] => name + | _ => error "Expected one source locale raw dispatcher") +val checked_alias = + #1 (Simplifier.check_simproc ctxt (alias, Position.none)) +val _ = AutoLocality_Assert.run_suite "Locale/source-local-dispatch" + [ ("source locale has one inventory identity", + fn () => AutoLocality_Assert.check "one source inventory identity" + (length inventory_entries = 1)), + ("source locale inventory alias resolves", + fn () => AutoLocality_Assert.check "source named dispatcher" + (checked_alias = alias)), + ("source locale has one raw dispatcher", + fn () => AutoLocality_Assert.check "one source raw dispatcher" + (length raw_dispatchers = 1)) ] + +end +\ + +end + +ML\ + val leaked_inventory = + LocalityDispatcherInventory.get (Context.Proof \<^context>) + |> LocalityDispatchKeyTable.dest + |> filter (fn (key, _) => + #head_name key = + AutoLocality_Test_Locale_Dispatch_Before.head_name) + val _ = AutoLocality_Assert.run_suite + "Locale/no-background-leak" + [ ("locale dispatcher remains local before interpretation", + fn () => AutoLocality_Assert.check "no top-level dispatcher" + (null leaked_inventory)) ] +\ + +subsection\Cancellation inside the locale\ + +context scaler begin + +text\A footprint-disjoint operation under the parameter-using attribute cancels by plain +@{term \simp\}.\ +lemma \bigval (setc c X) = bigval X\ by simp +lemma explicit_cancellation_uses_relative_index: + shows \bigval (setc c X) = bigval X\ + by (rule [[locality_autocancellation (loc) setc bigval 0]]) +lemma explicit_cancellation_uses_nonzero_relative_index: + shows \bigval_at n (setc c X) = bigval_at n X\ + by (rule [[locality_autocancellation (loc) setc bigval_at 1]]) +lemma \bigval (setc c (bumpval X)) = bigval (bumpval X)\ by simp +\\The parameter-using operation's own disjointness lemma holds.\ +lemma \ob (bumpval X) = ob X\ by simp + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_Test_Locale.loc" + val attr = "scaler.bigval" + val _ = AutoLocality_Assert.run_suite "Locale/local-context-simproc" + [ ("generic locale parameter cancels", + fn () => AutoLocality_Assert.assert_simproc_cancels_to ctxt rec_name attr + "scaler.bigval bump (setc c X)" "scaler.bigval bump X"), + ("generic locale parameter declines a shared footprint", + fn () => AutoLocality_Assert.assert_simproc_declines ctxt rec_name attr + "scaler.bigval bump (bumpval X)") ] +\ + +end + +subsection\Transport through @{command interpretation}\ + +text\Interpreting the locale instantiates the parameter with a concrete function. Because the +simproc pattern schematises the leading parameter position, the very same cancellation simproc fires +on the interpreted constants @{verbatim \sc.bigval\}, @{verbatim \sc.bumpval\}.\ + +interpretation sc: scaler \\n. n + 1\ . + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_Test_Locale.loc" + val raw_interpreted_pattern = \<^term>\scaler.bigval (\n. n + 1)\ + val interpreted_pattern = \<^term>\scaler.bigval Suc\ + val raw_interpreted_entry = + select_locality_entry_for_pattern ctxt rec_name "attribute" raw_interpreted_pattern + val interpreted_entry = + select_locality_entry_for_pattern ctxt rec_name "attribute" interpreted_pattern + val direct_result = + Option.map (fn entry => + locality_cancellation_simproc_for_entry rec_name entry ctxt + (Thm.cterm_of ctxt \<^term>\scaler.bigval Suc (setc c X)\)) + interpreted_entry + val _ = AutoLocality_Assert.run_suite "Locale/interpreted-registration" + [ ("raw interpreted entry exists", + fn () => AutoLocality_Assert.check "raw interpreted entry exists" + (Option.isSome raw_interpreted_entry)), + ("typed interpreted entry exists", + fn () => AutoLocality_Assert.check "typed interpreted entry exists" + (Option.isSome interpreted_entry)), + ("interpreted entry cancels directly", + fn () => AutoLocality_Assert.check "interpreted entry cancels directly" + (case direct_result of SOME (SOME _) => true | _ => false)) ] +\ + +lemma \sc.bigval (setc c X) = sc.bigval X\ by simp +lemma \sc.bigval (setc c (sc.bumpval X)) = sc.bigval (sc.bumpval X)\ by simp + +text\A second, independent interpretation works the same way.\ +interpretation sc2: scaler \\n. n * 2\ . + +lemma \sc2.bigval (setc c X) = sc2.bigval X\ by simp +lemma interpreted_simp_only_reactivation: + shows \sc.bigval (setc c X) = sc.bigval X \ + sc2.bigval (setc c X) = sc2.bigval X\ + by (simp only: [[locality_cancel]]) + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_Test_Locale.loc" + val attr = "scaler.bigval" + val first_entry = + select_locality_entry_for_pattern ctxt rec_name "attribute" + \<^term>\scaler.bigval Suc\ + val second_entry = + select_locality_entry_for_pattern ctxt rec_name "attribute" + \<^term>\scaler.bigval (\n. n * 2)\ + val interpreted_family_entries = + get_record_locality_entries rec_name ctxt + |> filter (fn entry => + locality_entry_kind entry = Locality_Attribute + andalso #const_name entry = + AutoLocality_Test_Locale_Dispatch_Before.head_name) + val inventory_entries = + LocalityDispatcherInventory.get (Context.Proof ctxt) + |> LocalityDispatchKeyTable.dest + |> map (fn (key, entry : locality_dispatcher_inventory_entry) => + (key, #alias entry)) + |> filter (fn (key, _) => + #head_name key = + AutoLocality_Test_Locale_Dispatch_Before.head_name) + val inventory_stable = + (case inventory_entries of + [(key, alias)] => + locality_dispatch_key_eq + (key, AutoLocality_Test_Locale_Dispatch_Before.dispatch_key) + andalso + #1 (Simplifier.check_simproc + ctxt (alias, Position.none)) = alias + | _ => false) + val raw_family_dispatchers = + Raw_Simplifier.simpset_of ctxt + |> Raw_Simplifier.dest_ss + |> #simprocs + |> filter (fn (name, _) => + name = AutoLocality_Test_Locale_Dispatch_Before.name) + val public_fact_base = + register_locality_attr_cancellation_thm_name + rec_name "bigval" 0 + val public_fact_names = + Global_Theory.facts_of (Proof_Context.theory_of ctxt) + |> Facts.dest_static true [] + |> map #1 + fun interpreted_public_fact_exists interpretation = + exists (fn name => + Long_Name.base_name name = public_fact_base + andalso member (op =) (Long_Name.explode name) interpretation) + public_fact_names + val _ = AutoLocality_Assert.run_suite "Locale/common-origin-dispatch" + [ ("interpretations retain distinct semantic entries", + fn () => AutoLocality_Assert.check "distinct interpreted entries" + (case (first_entry, second_entry) of + (SOME first, SOME second) => + length interpreted_family_entries = 2 + andalso not (locality_operational_key_eq + (#key first, #key second)) + | _ => false)), + ("first interpretation still cancels", + fn () => AutoLocality_Assert.assert_simproc_cancels_to + ctxt rec_name attr + "scaler.bigval Suc (setc c X)" + "scaler.bigval Suc X"), + ("second interpretation still cancels", + fn () => AutoLocality_Assert.assert_simproc_cancels_to + ctxt rec_name attr + "scaler.bigval (\n. n * 2) (setc c X)" + "scaler.bigval (\n. n * 2) X"), + ("interpretations retain their public facts", + fn () => AutoLocality_Assert.check "interpreted public facts" + (interpreted_public_fact_exists "sc" + andalso interpreted_public_fact_exists "sc2")), + ("interpretations retain one family inventory", + fn () => AutoLocality_Assert.check "stable interpreted inventory" + inventory_stable), + ("common-origin interpretations share one raw dispatcher", + fn () => AutoLocality_Assert.check "one interpreted raw dispatcher" + (length raw_family_dispatchers = 1)) ] +\ + +lemma repeated_cleared_reactivation_cancels: + shows \sc.bigval (setc c X) = sc.bigval X \ + sc2.bigval (setc c X) = sc2.bigval X\ + by (simp only: [[locality_cancel]] [[locality_cancel]]) + +subsection\Maximal dispatcher rank shadows lower registrations\ + +definition rank_shadow_attr :: \nat \ loc \ bool\ where + \rank_shadow_attr n R \ oa R > n\ + +locality_lemma for loc: \rank_shadow_attr\ footprint [oa] . + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_Test_Locale.loc" + val lower_entry = + (case select_locality_entry_for_pattern ctxt rec_name "attribute" + \<^term>\rank_shadow_attr\ of + SOME entry => entry + | NONE => error "Missing lower-ranked shadow registration") + val operation_entry = + (case select_locality_entry_for_pattern ctxt rec_name "operation" + \<^term>\setc\ of + SOME entry => entry + | NONE => error "Missing shadowing operation registration") + val dispatch_key = locality_dispatch_key_of_entry ctxt lower_entry + val higher_entry = + make_locality_entry rec_name Locality_Attribute + (#const_name lower_entry) + \<^term>\rank_shadow_attr (0 :: nat)\ + [false] ["oc"] 1 0 false [] [] NONE + val _ = + if locality_dispatch_key_eq + (dispatch_key, locality_dispatch_key_of_entry ctxt higher_entry) + then () + else error "Shadow registrations do not share a dispatch family" + val shadow_context = + Context.Proof ctxt + |> RecordLocalityData.map (insert_locality_entry higher_entry) + |> LocalitySecondaryIndex.map + (insert_locality_secondary_key_with_dispatch + (SOME dispatch_key) higher_entry) + val shadow_ctxt = Context.proof_of shadow_context + val redex = + Thm.cterm_of shadow_ctxt + \<^term>\rank_shadow_attr (0 :: nat) (setc c X)\ + val actual = Thm.term_of redex + val ranked_key_sets = + locality_dispatch_ranked_key_queries_with + locality_no_count shadow_ctxt dispatch_key actual + |> map (fn (query : locality_ranked_key_query) => + #retrieve query () + |> locality_equality_valid_keys_with + locality_no_count shadow_ctxt (#actual query)) + |> filter_out LocalityOperationalKeyTable.is_empty + + fun singleton_key_is entry keys = + (case LocalityOperationalKeyTable.keys keys of + [key] => locality_operational_key_eq (key, #key entry) + | _ => false) + + val maximal_is_higher = + (case ranked_key_sets of + keys :: _ => singleton_key_is higher_entry keys + | [] => false) + val lower_is_strictly_later = + (case ranked_key_sets of + _ :: lower_sets => + exists (fn keys => + LocalityOperationalKeyTable.defined keys (#key lower_entry)) + lower_sets + | [] => false) + val higher_result = + locality_cancellation_for_entry + rec_name higher_entry shadow_ctxt redex + val lower_result = + locality_cancellation_for_entry + rec_name lower_entry shadow_ctxt redex + val dispatcher_result = + locality_cancellation_simproc_for_dispatch + dispatch_key shadow_ctxt redex + val _ = AutoLocality_Assert.run_suite "Locale/maximal-rank-shadowing" + [ ("longer exact registration is the maximal nonempty rank", + fn () => AutoLocality_Assert.check "maximal shadow rank" + (maximal_is_higher andalso lower_is_strictly_later)), + ("higher footprint blocks while lower footprint permits cancellation", + fn () => AutoLocality_Assert.check "shadow footprint split" + (not (disjoint_footprint + (#footprint higher_entry) (#footprint operation_entry)) + andalso + disjoint_footprint + (#footprint lower_entry) (#footprint operation_entry))), + ("higher registration declines before using its empty payload", + fn () => AutoLocality_Assert.check "higher rank declines" + (null (#core_thms higher_entry) + andalso null (#disjoint_thms higher_entry) + andalso not (Option.isSome (#local_thm higher_entry)) + andalso + (case higher_result of NONE => true | SOME _ => false))), + ("lower registration would cancel the same redex", + fn () => AutoLocality_Assert.check "lower rank cancels" + (case lower_result of SOME _ => true | NONE => false)), + ("generic dispatcher does not fall through below maximal rank", + fn () => AutoLocality_Assert.check "maximal rank is terminal" + (case dispatcher_result of NONE => true | SOME _ => false)) ] +\ + +subsection\Generated theorem-note lifecycle\ + +named_theorems autolocality_explicit_operation_note_oracle +named_theorems autolocality_explicit_attribute_note_oracle + +definition note_default_op :: \loc \ loc\ where + \note_default_op R \ update_oa Suc R\ + +definition note_explicit_op :: \loc \ loc\ where + \note_explicit_op R \ update_ob Suc R\ + +definition note_default_attr :: \loc \ bool\ where + \note_default_attr R \ oa R = ob R\ + +definition note_explicit_attr :: \loc \ bool\ where + \note_explicit_attr R \ oa R \ ob R\ + +locality_lemma for loc: + \note_default_op\ footprint [oa, ob] . +locality_lemma for loc: + \note_default_attr\ footprint [oa, ob] . +locality_lemma for loc [autolocality_explicit_operation_note_oracle]: + \note_explicit_op\ footprint [oa, ob] . +locality_lemma for loc [autolocality_explicit_attribute_note_oracle]: + \note_explicit_attr\ footprint [oa, ob] . + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_Test_Locale.loc" + + fun operation_note_names pattern = + let + val public_id = locality_public_id ctxt pattern + in + [register_locality_op_commutativity_thm_name + rec_name public_id, + register_locality_op_disjointness_thm_name + rec_name public_id] + end + + fun attribute_note_name pattern = + register_locality_attr_cancellation_thm_name + rec_name (locality_public_id ctxt pattern) 0 + + fun public_facts names = + maps (Proof_Context.get_thms ctxt) names + + fun named_collection name = + Named_Theorems.get ctxt + (Named_Theorems.check ctxt (name, Position.none)) + + fun matching_facts collection public = + filter (fn observed => Thm.eq_thm_prop (public, observed)) + collection + + fun exact_public_activation collection public = + (case matching_facts collection public of + [observed] => + Thm.has_name_hint public + andalso Thm.has_name_hint observed + andalso Thm.get_name_hint public = Thm.get_name_hint observed + | _ => false) + + fun exact_anonymous_activation collection public = + (case matching_facts collection public of + [observed] => + Thm.has_name_hint public + andalso not (Thm.has_name_hint observed) + | _ => false) + + val default_operation_public = + operation_note_names \<^term>\note_default_op\ + |> public_facts + val default_attribute_public = + [attribute_note_name \<^term>\note_default_attr\] + |> public_facts + val explicit_operation_public = + operation_note_names \<^term>\note_explicit_op\ + |> public_facts + val explicit_attribute_public = + [attribute_note_name \<^term>\note_explicit_attr\] + |> public_facts + val default_observations = + named_collection (default_named_theorems_for_record rec_name) + val explicit_operation_observations = + named_collection "autolocality_explicit_operation_note_oracle" + val explicit_attribute_observations = + named_collection "autolocality_explicit_attribute_note_oracle" + + val _ = AutoLocality_Assert.run_suite "Locale/theorem-note-lifecycle" + [ ("default operation activates on exactly two public notes", + fn () => AutoLocality_Assert.check + "default operation public-note activations" + (length default_operation_public = 2 + andalso forall + (exact_public_activation default_observations) + default_operation_public)), + ("default attribute activates on exactly one public note", + fn () => AutoLocality_Assert.check + "default attribute public-note activation" + (length default_attribute_public = 1 + andalso forall + (exact_public_activation default_observations) + default_attribute_public)), + ("explicit operation keeps two anonymous attribute activations", + fn () => AutoLocality_Assert.check + "explicit operation public-plus-anonymous notes" + (length explicit_operation_public = 2 + andalso length explicit_operation_observations = 2 + andalso forall + (exact_anonymous_activation + explicit_operation_observations) + explicit_operation_public)), + ("explicit attribute keeps one anonymous attribute activation", + fn () => AutoLocality_Assert.check + "explicit attribute public-plus-anonymous notes" + (length explicit_attribute_public = 1 + andalso length explicit_attribute_observations = 1 + andalso forall + (exact_anonymous_activation + explicit_attribute_observations) + explicit_attribute_public)) ] +\ + +subsection\Simproc-level checks: bare-relative indices and fixpoint decline\ + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_Test_Locale.loc" + val attr = "scaler.bigval" + val _ = AutoLocality_Assert.run_suite "Locale/simproc" + [ \\The interpreted simproc zooms into the record (arg 1), not the locale parameter + (arg 0), so a disjoint operation cancels.\ + ("interpreted cancels to scaler.bigval (...) X", + fn () => AutoLocality_Assert.assert_simproc_cancels_to ctxt rec_name attr + "scaler.bigval (\n. n + 1) (setc c X)" "scaler.bigval (\n. n + 1) X"), + \\A footprint-sharing operation (bumpval shares [oa] with bigval) must be declined - no + loop.\ + ("declines footprint-sharing interpreted", + fn () => AutoLocality_Assert.assert_simproc_declines ctxt rec_name attr + "scaler.bigval (\n. n + 1) (scaler.bumpval (\n. n + 1) X)") ] +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Matrix.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Matrix.thy new file mode 100644 index 00000000..2d80b12b --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Matrix.thy @@ -0,0 +1,199 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Matrix + imports AutoLocality_Test_Common +begin +(*>*) + +section\Generated cancellation matrix at the top level\ + +text\A four-field record with a rich set of operations and attributes - single- and multi-field +footprints, opaque operations (bodies that read the old field value), bare field updates, field +selectors, and single- and multi-field attributes. The generator enumerates every +attribute-over-telescope combination and checks each against the independent footprint oracle, +turning a handful of declarations into many hundreds of checked cases. + +We silence the locality tracer for this theory (@{verbatim \locality_trace_level = 0\}): the matrix +fires the simproc many hundreds of times and the per-call trace would otherwise dominate the build +output. The cancellation behaviour is unaffected.\ + +declare [[locality_trace_level = 0]] + +datatype_record quad = + ma :: nat + mb :: nat + mc :: nat + md :: nat + +locality_init for quad + +\\Opaque single-field operations (read the old value, so unfolding really runs).\ +definition mop_a :: \nat \ quad \ quad\ where \mop_a k R \ update_ma (\old. old + k + ma R) R\ +definition mop_b :: \nat \ quad \ quad\ where \mop_b k R \ update_mb (\old. old * k) R\ +\\Set-style single-field operations.\ +definition mset_c :: \nat \ quad \ quad\ where \mset_c k \ update_mc (\_. k)\ +definition mset_d :: \nat \ quad \ quad\ where \mset_d k \ update_md (\_. k)\ +\\A two-field operation.\ +definition mop_cd :: \quad \ quad\ where \mop_cd R \ update_mc (\x. x + 1) (update_md (\y. y + 1) R)\ + +\\Attributes: single-field and multi-field.\ +definition mhas_a :: \quad \ bool\ where \mhas_a R \ ma R > 0\ +definition mread_b :: \quad \ nat\ where \mread_b R \ mb R + 1\ +definition mab_sum :: \quad \ nat\ where \mab_sum R \ ma R + mb R\ +definition mcd_sum :: \quad \ nat\ where \mcd_sum R \ mc R + md R\ + +locality_lemma for quad: \mop_a\ footprint [ma] . +locality_lemma for quad: \mop_b\ footprint [mb] . +locality_lemma for quad: \mset_c\ footprint [mc] . +locality_lemma for quad: \mset_d\ footprint [md] . +locality_lemma for quad: \mop_cd\ footprint [mc, md] . +locality_lemma for quad: \mhas_a\ footprint [ma] . +locality_lemma for quad: \mread_b\ footprint [mb] . +locality_lemma for quad: \mab_sum\ footprint [ma, mb] . +locality_lemma for quad: \mcd_sum\ footprint [mc, md] . + +ML\ + val ctxt = \<^context> + val rn = "AutoLocality_Test_Matrix.quad" + + \\User attributes and field-selector attributes; selectors are attributes too.\ + val attrs : AutoLocality_Gen.item list = + [ {name="mhas_a", fp=["ma"], arg=""}, {name="mread_b", fp=["mb"], arg=""}, + {name="mab_sum", fp=["ma","mb"], arg=""}, {name="mcd_sum", fp=["mc","md"], arg=""}, + {name="ma", fp=["ma"], arg=""}, {name="mb", fp=["mb"], arg=""}, + {name="mc", fp=["mc"], arg=""}, {name="md", fp=["md"], arg=""} ] + + \\Operations spanning all footprint shapes.\ + val ops : AutoLocality_Gen.item list = + [ {name="mop_a", fp=["ma"], arg="ka"}, {name="mop_b", fp=["mb"], arg="kb"}, + {name="mset_c", fp=["mc"], arg="kc"}, {name="mset_d", fp=["md"], arg="kd"}, + {name="mop_cd", fp=["mc","md"], arg=""} ] + + \\Attributes are registered under their base name (match index 0).\ + fun key (a : AutoLocality_Gen.item) = #name a + + fun assert_commutes a b = + AutoLocality_Assert.check (a ^ " commutes with " ^ b) + (Option.isSome (locality_prove_commutativity ctxt rn + (Syntax.read_term ctxt a) (Syntax.read_term ctxt b))) + + fun normalization_result term_str = + let + val term = Syntax.read_term ctxt term_str + val ctm = Thm.cterm_of ctxt term + val (head, args) = Term.strip_comb term + val attribute = + (case select_locality_entry ctxt rn "attribute" head args of + SOME (_, entry) => entry + | NONE => error ("No attribute entry for " ^ term_str)) + val decomposed = decompose_locality_telescope ctxt rn attribute term + val (_, hoisted, front, back) = hoist_redundant_operations decomposed + in + locality_prove_hoisting_by_normalization ctxt rn ctm + decomposed hoisted front back + end + +\ + +ML\ + val _ = AutoLocality_Assert.run_suite "Matrix/normalization-fast-path" + [ ("front-only normalization", + fn () => AutoLocality_Assert.check "front-only normalization" + (Option.isSome (normalization_result "mhas_a (mset_c kc R)"))), + ("simple mixed normalization", + fn () => AutoLocality_Assert.check "simple mixed normalization" + (Option.isSome + (normalization_result "mhas_a (mop_a ka (mset_c kc R))"))), + ("multi-field mixed normalization falls back", + fn () => AutoLocality_Assert.check "multi-field normalization boundary" + (not (Option.isSome + (normalization_result "mhas_a (mop_a ka (mop_cd R))")))) ] +\ + +ML\ + val n2 = AutoLocality_Gen.run_matrix "Matrix/top-level depth<=2" + ctxt rn key attrs ops 2 "R" + val _ = AutoLocality_Assert.check "depth<=2 matrix retained all 240 cases" (n2 = 240) +\ + +text\A depth-3 sweep over a representative subset - one single-field attribute, one multi-field +attribute, and three operations of different footprint shapes - adds longer telescopes (every +triple) without multiplying the case count across all eight attributes.\ + +ML\ + val ctxt = \<^context> + val rn = "AutoLocality_Test_Matrix.quad" + val attrs3 : AutoLocality_Gen.item list = + [ {name="mhas_a", fp=["ma"], arg=""}, {name="mcd_sum", fp=["mc","md"], arg=""} ] + val ops3 : AutoLocality_Gen.item list = + [ {name="mop_a", fp=["ma"], arg="ka"}, {name="mset_c", fp=["mc"], arg="kc"}, + {name="mop_cd", fp=["mc","md"], arg=""} ] + fun key (a : AutoLocality_Gen.item) = #name a +\ + +ML\ + val n3 = AutoLocality_Gen.run_matrix "Matrix/top-level depth<=3" + ctxt rn key attrs3 ops3 3 "R" + val _ = AutoLocality_Assert.check "depth<=3 matrix retained all 78 cases" (n3 = 78) +\ + +subsection\All ordered disjoint operation pairs\ + +text\Exercise every ordered disjoint pair through the public on-demand commutativity API after the +cold cancellation matrices. No theorem is registered in the proof context.\ + +ML\val _ = assert_commutes "mop_a" "mop_b"\ +ML\val _ = assert_commutes "mop_b" "mop_a"\ +ML\val _ = assert_commutes "mop_a" "mset_c"\ +ML\val _ = assert_commutes "mset_c" "mop_a"\ +ML\val _ = assert_commutes "mop_a" "mset_d"\ +ML\val _ = assert_commutes "mset_d" "mop_a"\ +ML\val _ = assert_commutes "mop_a" "mop_cd"\ +ML\val _ = assert_commutes "mop_cd" "mop_a"\ +ML\val _ = assert_commutes "mop_b" "mset_c"\ +ML\val _ = assert_commutes "mset_c" "mop_b"\ +ML\val _ = assert_commutes "mop_b" "mset_d"\ +ML\val _ = assert_commutes "mset_d" "mop_b"\ +ML\val _ = assert_commutes "mop_b" "mop_cd"\ +ML\val _ = assert_commutes "mop_cd" "mop_b"\ +ML\val _ = assert_commutes "mset_c" "mset_d"\ +ML\val _ = assert_commutes "mset_d" "mset_c"\ + +subsection\The oracle has teeth: a deliberately wrong oracle is caught\ + +text\To show the matrix is not a tautology, we run a batch of cases against a corrupted oracle that +claims \<^emph>\everything\ cancels. The simproc must disagree on a non-trivial number of them; a count of +zero would mean the oracle and simproc were not actually cross-checking.\ + +ML\ + val ctxt = \<^context> + val rn = "AutoLocality_Test_Matrix.quad" + val attrs = [ {name="mab_sum", fp=["ma","mb"], arg=""} : AutoLocality_Gen.item ] + val ops = [ {name="mop_a", fp=["ma"], arg="ka"} : AutoLocality_Gen.item, + {name="mset_c", fp=["mc"], arg="kc"} : AutoLocality_Gen.item ] + val cases = maps (fn a => map (fn t => (a, t)) (AutoLocality_Gen.telescopes ops 2)) attrs + \\Corrupted expectation: claim ALL operations cancel (residual = bare base). Count how many + cases the real simproc disagrees with.\ + fun caught (a, t) = + let + val lhs = AutoLocality_Gen.build_term a t "R" + val wrong_rhs = AutoLocality_Gen.build_term a [] "R" + in + case AutoLocality_Assert.simproc_on ctxt rn (#name a) lhs of + NONE => true + | SOME thm => + (case Thm.prop_of thm of + Const ("Pure.eq", _) $ _ $ rhs => not (Term.aconv (rhs, Syntax.read_term ctxt wrong_rhs)) + | _ => true) + end + val n = length (List.filter caught cases) + val _ = AutoLocality_Assert.check + ("wrong oracle caught on " ^ Int.toString n ^ "/" ^ Int.toString (length cases) ^ " cases") + (n > 0) +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Matrix_Locale.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Matrix_Locale.thy new file mode 100644 index 00000000..4f8c3031 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Matrix_Locale.thy @@ -0,0 +1,112 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Matrix_Locale + imports AutoLocality_Test_Common +begin +(*>*) + +section\Generated cancellation matrix in locale and interpretation contexts\ + +text\The same generator as @{theory_text \AutoLocality_Test_Matrix\}, but exercising the locale code +paths that the locale fix is about: a parameter-using attribute and a parameter-using operation are +defined in a locale and registered from a @{command context} re-entry, alongside top-level +parameter-free operations to cancel against. The matrix runs three times - inside the locale, and +under two distinct @{command interpretation}s - to show the cancellation simproc transports through +interpretation across the whole telescope matrix, not just on the hand-picked cases in +@{theory_text \AutoLocality_Test_Locale\}. + +The matrix names carry the context prefix (the bare name in-locale, @{verbatim \i1.\}/@{verbatim \i2.\} +under the interpretations), while the simproc key is always the registered base name; the +@{verbatim \key\} argument to @{ML AutoLocality_Gen.run_matrix} strips the prefix back to the base.\ + +declare [[locality_trace_level = 0]] + +datatype_record lrec = + va :: nat + vb :: nat + vc :: nat + vd :: nat + +locality_init for lrec + +\\Top-level parameter-free operations on each field, to cancel against (these are found by the + picker in every context, unlike a parameter-free op defined inside the locale).\ +definition vset_a :: \nat \ lrec \ lrec\ where \vset_a k \ update_va (\_. k)\ +definition vset_b :: \nat \ lrec \ lrec\ where \vset_b k \ update_vb (\_. k)\ +definition vset_c :: \nat \ lrec \ lrec\ where \vset_c k \ update_vc (\_. k)\ +definition vset_d :: \nat \ lrec \ lrec\ where \vset_d k \ update_vd (\_. k)\ + +locality_lemma for lrec: \vset_a\ footprint [va] . +locality_lemma for lrec: \vset_b\ footprint [vb] . +locality_lemma for lrec: \vset_c\ footprint [vc] . +locality_lemma for lrec: \vset_d\ footprint [vd] . + +locale scaler = + fixes bump :: \nat \ nat\ +begin + +\\Parameter-using attributes: single- and multi-field.\ +definition big_a :: \lrec \ bool\ where \big_a R \ bump (va R) > 10\ +definition sum_ab :: \lrec \ nat\ where \sum_ab R \ bump (va R) + vb R\ +\\A parameter-using operation.\ +definition bump_a :: \lrec \ lrec\ where \bump_a R \ update_va bump R\ + +end + +text\Register the locale constants from a re-entry (the auto-derivation needs the definitions to be +established), with their short names.\ + +context scaler begin +locality_lemma for lrec: \big_a\ footprint [va] . +locality_lemma for lrec: \sum_ab\ footprint [va, vb] . +locality_lemma for lrec: \bump_a\ footprint [va] . +end + +subsection\Matrix inside the locale\ + +context scaler begin +ML\ + val ctxt = \<^context> + val rn = "AutoLocality_Test_Matrix_Locale.lrec" + \\In-locale: the abbreviations apply the parameter implicitly, so names are bare short names.\ + val attrs : AutoLocality_Gen.item list = + [ {name="big_a", fp=["va"], arg=""}, {name="sum_ab", fp=["va","vb"], arg=""} ] + val ops : AutoLocality_Gen.item list = + [ {name="bump_a", fp=["va"], arg=""}, {name="vset_b", fp=["vb"], arg="kb"}, + {name="vset_c", fp=["vc"], arg="kc"}, {name="vset_d", fp=["vd"], arg="kd"} ] + fun key (a : AutoLocality_Gen.item) = #name a + val n = AutoLocality_Gen.run_matrix "Locale-matrix/in-locale" ctxt rn key attrs ops 2 "R" +\ +end + +subsection\Matrix under two interpretations\ + +interpretation i1: scaler \\n. n + 1\ . +interpretation i2: scaler \\n. n * 3\ . + +ML\ + val ctxt = \<^context> + val rn = "AutoLocality_Test_Matrix_Locale.lrec" + + \\Under an interpretation, attribute/operation names carry the interpretation prefix; the + registered simproc key is the base name (strip everything up to the last dot).\ + fun base nm = List.last (String.tokens (fn c => c = #".") nm) + fun key (a : AutoLocality_Gen.item) = base (#name a) + + fun attrs pre = [ {name=pre^"big_a", fp=["va"], arg=""} : AutoLocality_Gen.item, + {name=pre^"sum_ab", fp=["va","vb"], arg=""} : AutoLocality_Gen.item ] + fun ops pre = [ {name=pre^"bump_a", fp=["va"], arg=""} : AutoLocality_Gen.item, + {name="vset_b", fp=["vb"], arg="kb"} : AutoLocality_Gen.item, + {name="vset_c", fp=["vc"], arg="kc"} : AutoLocality_Gen.item, + {name="vset_d", fp=["vd"], arg="kd"} : AutoLocality_Gen.item ] + + val n1 = AutoLocality_Gen.run_matrix "Locale-matrix/interp i1" ctxt rn key (attrs "i1.") (ops "i1.") 2 "R" + val n2 = AutoLocality_Gen.run_matrix "Locale-matrix/interp i2" ctxt rn key (attrs "i2.") (ops "i2.") 2 "R" + val _ = writeln ("Locale matrix checked " ^ Int.toString (n1 + n2) ^ " interpreted cases") +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Perf.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Perf.thy new file mode 100644 index 00000000..8765c571 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Perf.thy @@ -0,0 +1,167 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Perf + imports AutoLocality_Test_Common +begin +(*>*) + +section\Performance guards for on-the-fly cancellation\ + +text\On-the-fly cancellation re-derives each rewrite with a tactic, so a pathological term could in +principle be slow. This suite bounds the cost: deep telescopes of footprint-disjoint operations, and +wide footprints with several attributes, must all cancel well within a few seconds. Each case is run +through @{verbatim \cancels_within\}, which fails on timeout. The bounds are generous (4s) - they are a +regression tripwire against accidental blow-up, not a tight benchmark.\ + +datatype_record perf = + qa :: nat + qb :: nat + qc :: nat + qd :: nat + +locality_init for perf + +definition pset_a :: \nat \ perf \ perf\ where \pset_a k \ update_qa (\_. k)\ +definition pset_b :: \nat \ perf \ perf\ where \pset_b k \ update_qb (\_. k)\ +definition pset_c :: \nat \ perf \ perf\ where \pset_c k \ update_qc (\_. k)\ +definition pset_d :: \nat \ perf \ perf\ where \pset_d k \ update_qd (\_. k)\ +\\An opaque operation on \qc\ whose body uses the old value.\ +definition pbump_c :: \nat \ perf \ perf\ where \pbump_c k R \ update_qc (\old. old + k + qc R) R\ +definition pdelegate_c :: \nat \ perf \ perf\ where + \pdelegate_c k R \ pbump_c k R\ +\\Attribute on \qd\: disjoint from all of pset_a/pset_b/pset_c/pbump_c.\ +definition phas_d :: \perf \ bool\ where \phas_d R \ qd R > 0\ + +locality_lemma for perf: \pset_a\ footprint [qa] . +locality_lemma for perf: \pset_b\ footprint [qb] . +locality_lemma for perf: \pset_c\ footprint [qc] . +locality_lemma for perf: \pset_d\ footprint [qd] . +locality_lemma for perf: \pbump_c\ footprint [qc] . +locality_lemma for perf: \pdelegate_c\ footprint [qc] . +locality_lemma for perf: \phas_d\ footprint [qd] . + +text\Sanity: a deep nest cancels by plain @{term \simp\} as an object-level lemma too.\ +lemma \phas_d (pset_a a (pset_b b (pset_c c (pbump_c k (pset_a a2 X))))) = phas_d X\ + by simp + +ML\ + val ctxt = \<^context> + \\Build an n-deep telescope of disjoint operations under phas_d and time its cancellation.\ + fun deep n = + let + val ops = ["pset_a a", "pset_b b", "pset_c c", "pbump_c k"] + fun wrap i body = (nth ops (i mod 4)) ^ " (" ^ body ^ ")" + val inner = fold wrap (0 upto (n - 1)) "X" + in "phas_d (" ^ inner ^ ") = phas_d X" end + val _ = AutoLocality_Assert.run_suite "Perf/telescope-depth" + [ ("depth 4 within 4s", fn () => AutoLocality_Assert.check "depth 4" (AutoLocality_Assert.cancels_within ctxt 4000 (deep 4))), + ("depth 8 within 4s", fn () => AutoLocality_Assert.check "depth 8" (AutoLocality_Assert.cancels_within ctxt 4000 (deep 8))), + ("depth 16 within 4s", fn () => AutoLocality_Assert.check "depth 16" (AutoLocality_Assert.cancels_within ctxt 4000 (deep 16))) ] +\ + +text\A cancellable operation can sit directly under an attribute while its record argument contains +a deep body of operations that overlap the attribute. Cancellation must remove only the front +operation without simplifying the blocked body again. Give every layer a distinct argument so term +sharing cannot collapse the telescope.\ +ML\ + val ctxt = \<^context> + val blocked = Syntax.read_term ctxt "pset_d" + val front = Syntax.read_term ctxt "pset_a" + val attribute = Syntax.read_term ctxt "phas_d" + val state = Syntax.read_term ctxt "X :: perf" + fun indexed_operation operation prefix i inner = + operation $ Free (prefix ^ Int.toString i, HOLogic.natT) $ inner + fun front_over_blocked n = + let + val body = fold (indexed_operation blocked "d") + (1 upto n) state + val front_body = front $ Free ("a", HOLogic.natT) $ body + in + HOLogic.mk_Trueprop + (HOLogic.mk_eq (attribute $ front_body, attribute $ body)) + end + fun all_front n = + let + val body = fold (indexed_operation front "a") + (1 upto n) state + in + HOLogic.mk_Trueprop + (HOLogic.mk_eq (attribute $ body, attribute $ state)) + end + fun cancels context goal = + (Goal.prove context [] [] goal + (fn {context, ...} => asm_full_simp_tac context 1); + true) + handle ERROR _ => false | THM _ => false + fun timed_cancels_within context label ms goal = + let + val start = Timing.start () + val result = + Timeout.apply (Time.fromMilliseconds (IntInf.fromInt ms)) + (fn () => cancels context goal) () + handle Timeout.TIMEOUT _ => false + val _ = writeln (label ^ ": " ^ Timing.message (Timing.result start)) + in result end + val (blocked_run, blocked_ctxt) = + AutoLocality_Instrumentation.start_run ctxt + val blocked_outcome = + Exn.capture + (fn () => + timed_cancels_within blocked_ctxt + "Perf/front-over-blocked depth 5000" 4000 + (front_over_blocked 5000)) () + val blocked_snapshot_option = + AutoLocality_Instrumentation.freeze_run blocked_run + val blocked_dropped = + AutoLocality_Instrumentation.drop_run blocked_run + val blocked_result = Exn.release blocked_outcome + val blocked_snapshot = + (case blocked_snapshot_option of + SOME snapshot => snapshot + | NONE => error "Missing front-over-blocked instrumentation snapshot") + val blocked_clean_freeze = + AutoLocality_Instrumentation.snapshot_phase blocked_snapshot = + AutoLocality_Instrumentation.Frozen + andalso + AutoLocality_Instrumentation.snapshot_active_callbacks + blocked_snapshot = 0 + andalso + AutoLocality_Instrumentation.snapshot_async_leases + blocked_snapshot = 0 + val blocked_avoids_record_simpset = + AutoLocality_Instrumentation.snapshot_counter blocked_snapshot + AutoLocality_Instrumentation.Record_Simpset_Builds = 0 + val _ = AutoLocality_Assert.run_suite "Perf/front-over-blocked" + [ ("depth 5000 within 4s", + fn () => AutoLocality_Assert.check "front-over-blocked depth 5000" + blocked_result), + ("does not build a record simpset", + fn () => AutoLocality_Assert.check "no record simpset build" + blocked_avoids_record_simpset), + ("instrumentation run freezes drained", + fn () => AutoLocality_Assert.check "clean freeze" + blocked_clean_freeze), + ("instrumentation run drops", + fn () => AutoLocality_Assert.check "clean drop" + blocked_dropped) ] + val _ = AutoLocality_Assert.run_suite "Perf/all-front" + [ ("depth 4096 within 4s", + fn () => AutoLocality_Assert.check "all-front depth 4096" + (timed_cancels_within ctxt "Perf/all-front depth 4096" + 4000 (all_front 4096))) ] +\ + +text\Wide: every field-projection attribute cancels a disjoint operation, each within budget.\ +ML\ + val ctxt = \<^context> + val _ = AutoLocality_Assert.run_suite "Perf/wide-attrs" + [ ("qa proj", fn () => AutoLocality_Assert.check "qa" (AutoLocality_Assert.cancels_within ctxt 4000 "qa (pset_b b (pset_c c X)) = qa X")), + ("qb proj", fn () => AutoLocality_Assert.check "qb" (AutoLocality_Assert.cancels_within ctxt 4000 "qb (pset_a a (pset_c c X)) = qb X")), + ("qd attr", fn () => AutoLocality_Assert.check "qd" (AutoLocality_Assert.cancels_within ctxt 4000 "phas_d (pset_a a (pset_b b (pset_c c X))) = phas_d X")) ] +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Polymorphic.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Polymorphic.thy new file mode 100644 index 00000000..e885a309 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Polymorphic.thy @@ -0,0 +1,351 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Polymorphic + imports AutoLocality_Test_Common +begin +(*>*) + +section\Sort-constrained polymorphic records and definitions\ + +datatype_record ('a::linorder, 'b::monoid_add) poly = + pkey :: 'a + pacc :: 'b + pflag :: bool + +locality_init for poly + +definition poly_raise_key :: + \'a::linorder \ ('a, 'b::monoid_add) poly \ ('a, 'b) poly\ + where + \poly_raise_key k R \ update_pkey (max k) R\ + +definition poly_add_acc :: + \'b::monoid_add \ ('a::linorder, 'b) poly \ ('a, 'b) poly\ + where + \poly_add_acc n R \ update_pacc (\x. x + n) R\ + +definition poly_set_flag :: + \bool \ ('a::linorder, 'b::monoid_add) poly \ ('a, 'b) poly\ + where + \poly_set_flag b R \ update_pflag (\_. b) R\ + +definition poly_key_le :: + \'a::linorder \ ('a, 'b::monoid_add) poly \ bool\ + where + \poly_key_le k R \ pkey R \ k\ + +definition poly_acc_eq :: + \'b::monoid_add \ ('a::linorder, 'b) poly \ bool\ + where + \poly_acc_eq n R \ pacc R = n\ + +locality_lemma for poly: \poly_raise_key\ footprint [pkey] . +locality_lemma for poly: \poly_add_acc\ footprint [pacc] . +locality_lemma for poly: \poly_set_flag\ footprint [pflag] . +locality_lemma for poly: \poly_key_le\ footprint [pkey] . +locality_lemma for poly: \poly_acc_eq\ footprint [pacc] . + +lemma \poly_key_le k (poly_add_acc n (poly_set_flag b R)) = poly_key_le k R\ + by simp + +lemma \poly_acc_eq n (poly_raise_key k (poly_set_flag b R)) = poly_acc_eq n R\ + by simp + +lemma \pflag (poly_add_acc n (poly_raise_key k R)) = pflag R\ + by simp + +lemma + fixes R :: \(nat, nat) poly\ + shows \poly_key_le 3 (poly_add_acc 5 (poly_set_flag True R)) = + poly_key_le 3 R\ + by simp + +subsection\Locale assumptions retain their fixed type parameters\ + +datatype_record ('a::linorder, 'phantom) locale_poly = + locale_payload :: 'a + locale_mark :: bool + +locality_init for locale_poly + +definition locale_payload_touch :: + \'tag \ ('a::linorder, 'phantom) locale_poly \ + ('a, 'phantom) locale_poly\ where + \locale_payload_touch _ R \ update_locale_payload id R\ + +locality_lemma for locale_poly: + \locale_payload_touch\ footprint [locale_payload] . + +subsection\One operation at distinct phantom specializations\ + +lemma locale_payload_phantom_schedule: + fixes R :: \(nat, bool) locale_poly\ + and unit_tag :: unit + and string_tag :: string + shows \locale_mark + (locale_payload_touch unit_tag + (locale_payload_touch string_tag R)) = + locale_mark R\ + by simp + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_Test_Polymorphic.locale_poly" + val sample = + Syntax.read_term ctxt + "locale_mark \ + \(locale_payload_touch (unit_tag :: unit) \ + \(locale_payload_touch (string_tag :: string) \ + \(R :: (nat, bool) locale_poly)))" + val (sample_head, sample_args) = Term.strip_comb sample + val attribute = + (case select_locality_entry ctxt rec_name "attribute" + sample_head sample_args of + SOME (_, entry) => entry + | NONE => error "Missing polymorphic locale_mark attribute") + val operation_entries = + (case fst (decompose_locality_telescope + ctxt rec_name attribute sample) of + _ :: operations => map #1 operations + | [] => []) + val same_key = + (case operation_entries of + [operation0, operation1] => + locality_operational_key_eq + (#key operation0, #key operation1) + | _ => false) + val distinct_typed_patterns = + (case operation_entries of + [operation0, operation1] => + not (Term.aconv + (#pattern operation0, #pattern operation1)) + | _ => false) + val expected_rhs = + Syntax.read_term ctxt + "locale_mark \ + \(R :: (nat, bool) locale_poly)" + val (run_id, run_ctxt) = + AutoLocality_Instrumentation.start_run ctxt + val direct_outcome = + Exn.capture + (fn () => + locality_cancellation_simproc + rec_name "locale_mark" 0 run_ctxt + (Thm.cterm_of run_ctxt sample)) () + val snapshot_option = + AutoLocality_Instrumentation.freeze_run run_id + val dropped = + AutoLocality_Instrumentation.drop_run run_id + val snapshot = + (case snapshot_option of + SOME value => value + | NONE => error "Missing polymorphic cancellation snapshot") + val direct_result = Exn.release direct_outcome + val direct_rhs_matches = + (case direct_result of + SOME thm => Term.aconv + (Thm.term_of (Thm.rhs_of thm), expected_rhs) + | NONE => false) + val clean_freeze = + AutoLocality_Instrumentation.snapshot_phase snapshot = + AutoLocality_Instrumentation.Frozen + andalso + AutoLocality_Instrumentation.snapshot_active_callbacks snapshot = 0 + andalso + AutoLocality_Instrumentation.snapshot_async_leases snapshot = 0 + val exact_root_rewrites = + AutoLocality_Instrumentation.snapshot_counter snapshot + AutoLocality_Instrumentation.Planner_Root_Rewrites = 2 + val _ = AutoLocality_Assert.run_suite + "Polymorphic/phantom-specialization-schedule" + [ ("two operation occurrences are decomposed", + fn () => AutoLocality_Assert.check "two operations" + (length operation_entries = 2)), + ("operation occurrences share one operational key", + fn () => AutoLocality_Assert.check "same operational key" + same_key), + ("operation occurrences retain distinct typed patterns", + fn () => AutoLocality_Assert.check "distinct typed patterns" + distinct_typed_patterns), + ("direct cancellation reaches the typed input attribute", + fn () => AutoLocality_Assert.check "direct cancellation RHS" + direct_rhs_matches), + ("direct cancellation schedules exactly two root rewrites", + fn () => AutoLocality_Assert.check "two root rewrites" + exact_root_rewrites), + ("instrumentation run freezes drained", + fn () => AutoLocality_Assert.check "clean freeze" + clean_freeze), + ("instrumentation run drops", + fn () => AutoLocality_Assert.check "clean drop" + dropped) ] +\ + +locale polymorphic_locale = + fixes witness :: \'a::linorder\ + assumes witness_bound: \witness \ witness\ +begin + +definition locale_marked :: \('a, 'phantom) locale_poly \ bool\ where + \locale_marked R \ locale_mark R\ + +end + +context polymorphic_locale begin + +locality_lemma for locale_poly: \locale_marked\ footprint [locale_mark] . + +lemma \locale_mark (update_locale_payload f R) = locale_mark R\ + by simp + +lemma \locale_marked (update_locale_payload f R) = locale_marked R\ + by simp + +end + +global_interpretation polymorphic_nat: + polymorphic_locale \0 :: nat\ + by standard simp + +global_interpretation polymorphic_int: + polymorphic_locale \0 :: int\ + by standard simp + +lemma polymorphic_locale_nat_interpretation: + fixes R :: \(nat, bool) locale_poly\ + shows \polymorphic_nat.locale_marked + (locale_payload_touch () R) = + polymorphic_nat.locale_marked R\ + by (simp only: [[locality_cancel]]) + +lemma polymorphic_locale_int_interpretation: + fixes R :: \(int, unit) locale_poly\ + shows \polymorphic_int.locale_marked + (locale_payload_touch True R) = + polymorphic_int.locale_marked R\ + by (simp only: [[locality_cancel]]) + +ML\ + val ctxt = \<^context> + val rec_name = + "AutoLocality_Test_Polymorphic.locale_poly" + val head_name = + "AutoLocality_Test_Polymorphic.polymorphic_locale.locale_marked" + val semantic_entries = + get_record_locality_entries rec_name ctxt + |> filter (fn entry => #const_name entry = head_name) + val inventory_entries = + LocalityDispatcherInventory.get (Context.Proof ctxt) + |> LocalityDispatchKeyTable.dest + |> filter (fn (key, _) => #head_name key = head_name) + val physical_shape = + (case inventory_entries of + [(_, entry : locality_dispatcher_inventory_entry)] => + let + val checked_alias = + #1 (Simplifier.check_simproc + ctxt (#alias entry, Position.none)) + val raw_count = + Raw_Simplifier.simpset_of ctxt + |> Raw_Simplifier.dest_ss + |> #simprocs + |> filter (fn (name, _) => name = #source_name entry) + |> length + in + checked_alias = #alias entry andalso raw_count = 1 + end + | _ => false) + val _ = AutoLocality_Assert.run_suite + "Polymorphic/distinct-type-interpretations" + [ ("distinct concrete types retain two semantic entries", + fn () => AutoLocality_Assert.check + "typed semantic interpretations" + (length semantic_entries = 2)), + ("distinct concrete types share one physical dispatcher", + fn () => AutoLocality_Assert.check + "shared polymorphic dispatcher" + physical_shape) ] +\ + +ML\ + val ctxt = \<^context> + val (rec_ty, _) = prepare_rec_name ctxt "poly" + val sorts_preserved = + (case rec_ty of + Type (_, [TVar (_, key_sort), TVar (_, acc_sort)]) => + not (null key_sort) andalso not (null acc_sort) + | _ => false) + val entries = + get_record_locality_entries "AutoLocality_Test_Polymorphic.poly" ctxt + val polymorphic_patterns = + entries + |> filter (fn entry => + member (op =) + ["AutoLocality_Test_Polymorphic.poly_raise_key", + "AutoLocality_Test_Polymorphic.poly_add_acc", + "AutoLocality_Test_Polymorphic.poly_key_le", + "AutoLocality_Test_Polymorphic.poly_acc_eq"] + (#const_name entry)) + |> forall (fn entry => not (null (Term.add_tvars (#pattern entry) []))) + val _ = AutoLocality_Assert.run_suite "Polymorphic/metadata" + [ ("record type-variable sorts are retained", + fn () => AutoLocality_Assert.check "sorts retained" sorts_preserved), + ("registered patterns remain polymorphic", + fn () => AutoLocality_Assert.check "polymorphic patterns" + polymorphic_patterns) ] +\ + +subsection\Concrete type instances exercise the same registrations\ + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_Test_Polymorphic.poly" + val sample = + Syntax.read_term ctxt + "poly_key_le (3::nat) (poly_add_acc (5::nat) (R::(nat,nat) poly))" + val (sample_head, sample_args) = Term.strip_comb sample + val selected_attr = + select_locality_entry ctxt rec_name "attribute" sample_head sample_args + val selected_op = + let + val (_, attr_args) = Term.strip_comb sample + val (op_head, op_args) = Term.strip_comb (List.last attr_args) + in + select_locality_entry ctxt rec_name "operation" op_head op_args + end + val direct_result = + (case selected_attr of + SOME (_, entry) => + locality_cancellation_simproc_for_entry rec_name entry ctxt + (Thm.cterm_of ctxt sample) + | NONE => NONE) + val _ = AutoLocality_Assert.run_suite "Polymorphic/concrete-selection" + [ ("concrete attribute selects the polymorphic registration", + fn () => AutoLocality_Assert.check "concrete attribute selected" + (Option.isSome selected_attr)), + ("concrete operation selects the polymorphic registration", + fn () => AutoLocality_Assert.check "concrete operation selected" + (Option.isSome selected_op)), + ("concrete cancellation proof succeeds directly", + fn () => AutoLocality_Assert.check "concrete cancellation" + (Option.isSome direct_result)) ] + + val attrs : AutoLocality_Gen.item list = + [ {name = "poly_key_le", fp = ["pkey"], arg = "(3::nat)"}, + {name = "poly_acc_eq", fp = ["pacc"], arg = "(7::nat)"} ] + val ops : AutoLocality_Gen.item list = + [ {name = "poly_raise_key", fp = ["pkey"], arg = "(4::nat)"}, + {name = "poly_add_acc", fp = ["pacc"], arg = "(5::nat)"}, + {name = "poly_set_flag", fp = ["pflag"], arg = "True"} ] + val count = + AutoLocality_Gen.run_matrix "Polymorphic/nat-instance" ctxt rec_name + (Long_Name.base_name o #name) attrs ops 3 + "(R::(nat,nat) poly)" + val _ = AutoLocality_Assert.check "polymorphic matrix has 78 cases" (count = 78) +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Record_Extension.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Record_Extension.thy new file mode 100644 index 00000000..ef860c26 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Record_Extension.thy @@ -0,0 +1,75 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Record_Extension + imports AutoLocality_Test_Common +begin +(*>*) + +section\Standard Isabelle record extensions\ + +record standard_base = + std_a :: nat + std_b :: nat + +record standard_ext = standard_base + + std_c :: nat + +locality_init for standard_ext + +definition std_bump_a :: \standard_ext \ standard_ext\ where + \std_bump_a R \ std_a_update Suc R\ + +definition std_set_c :: \nat \ standard_ext \ standard_ext\ where + \std_set_c n R \ std_c_update (\_. n) R\ + +definition std_has_b :: \standard_ext \ bool\ where + \std_has_b R \ std_b R > 0\ + +locality_lemma for standard_ext: \std_bump_a\ footprint [std_a] . +locality_lemma for standard_ext: \std_set_c\ footprint [std_c] . +locality_lemma for standard_ext: \std_has_b\ footprint [std_b] . + +lemma \std_has_b (std_bump_a (std_set_c n R)) = std_has_b R\ + by simp + +lemma \std_has_b (std_a_update f (std_c_update g R)) = std_has_b R\ + by simp + +lemma \std_c (std_bump_a R) = std_c R\ + by simp + +lemma \std_c (std_a_update f R) = std_c R\ + by simp + +ML\ + val ctxt = \<^context> + val rec_name = "AutoLocality_Test_Record_Extension.standard_ext" + val entries = get_record_locality_entries rec_name ctxt + fun one name = + entries |> filter (fn entry => #const_name entry = name) + val expected_fields = + ["AutoLocality_Test_Record_Extension.standard_base.std_a", + "AutoLocality_Test_Record_Extension.standard_base.std_b", + "AutoLocality_Test_Record_Extension.standard_ext.std_c"] + val expected_updates = map (suffix Record.updateN) expected_fields + val registered_fields = + entries |> filter #field |> map #const_name + val _ = AutoLocality_Assert.run_suite "Record-extension/metadata" + [ ("inherited and new selectors are registered", + fn () => AutoLocality_Assert.check "all standard selectors" + (List.all (member (op =) registered_fields) expected_fields)), + ("inherited and new updaters are registered", + fn () => AutoLocality_Assert.check "all standard updaters" + (List.all (member (op =) registered_fields) expected_updates)), + ("custom inherited-field operation remains non-field", + fn () => AutoLocality_Assert.check "custom operation" + (case one "AutoLocality_Test_Record_Extension.std_bump_a" of + [entry] => not (#field entry) + | _ => false)) ] +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Shapes.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Shapes.thy new file mode 100644 index 00000000..6b5ddd75 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Shapes.thy @@ -0,0 +1,140 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Shapes + imports AutoLocality_Test_Common +begin +(*>*) + +section\Argument shapes: extra arguments, record position, polymorphism, and a known limitation\ + +text\Operations and attributes come in more shapes than \f R\. This suite covers attributes with +extra non-record arguments, the record sitting at a non-zero argument position, polymorphic records +and operations (including a partially instantiated one), and documents the one genuine +classification limitation: a function with two record-typed arguments is treated as an attribute, +not an operation.\ + +subsection\Extra arguments and non-zero record position\ + +datatype_record shp = + sa :: nat + sb :: nat + sc :: nat + +locality_init for shp + +definition sset_c :: \nat \ shp \ shp\ where + \sset_c k \ update_sc (\_. k)\ +\\Attribute with an extra (non-record) argument, record at index 0.\ +definition sa_exceeds :: \shp \ nat \ bool\ where + \sa_exceeds R n \ sa R > n\ +\\Attribute with the record at argument index 1 (its only record argument), match index 0.\ +definition sb_below :: \nat \ shp \ bool\ where + \sb_below n R \ sb R < n\ +\\Attribute with two non-record arguments straddling the record (index 1).\ +definition sa_between :: \nat \ shp \ nat \ bool\ where + \sa_between lo R hi \ lo < sa R \ sa R < hi\ + +locality_lemma for shp: \sset_c\ footprint [sc] . +locality_lemma for shp: \sa_exceeds\ footprint [sa] . +locality_lemma for shp: \sb_below\ [0] footprint [sb] . +locality_lemma for shp: \sa_between\ [0] footprint [sa] . + +text\Each cancels its footprint-disjoint inner operation, regardless of where the record sits or how +many extra arguments surround it.\ +lemma \sa_exceeds (sset_c c X) n = sa_exceeds X n\ by simp +lemma \sb_below n (sset_c c X) = sb_below n X\ by simp +lemma \sa_between lo (sset_c c X) hi = sa_between lo X hi\ by simp + +subsection\Function-valued field selectors\ + +datatype_record function_field_shape = + ffs_counter :: nat + ffs_lookup :: \nat \ bool\ + +locality_init for function_field_shape + +definition ffs_touch_counter :: + \nat \ function_field_shape \ function_field_shape\ where + \ffs_touch_counter k R \ + update_ffs_counter (\old. old + k + ffs_counter R) R\ + +locality_lemma for function_field_shape: + \ffs_touch_counter\ footprint [ffs_counter] . + +text\A generated selector for a function-valued field is registered at its record argument, while +its physical simplifier trigger sees the selector's complete application. Cancellation rewrites +the registered selector prefix and preserves the trailing lookup argument.\ +lemma \ffs_lookup (ffs_touch_counter k R) i = ffs_lookup R i\ + by simp + +ML\ + val ctxt = \<^context> + val _ = AutoLocality_Assert.run_suite "Shapes/function-valued-field" + [("direct simproc preserves the trailing lookup argument", + fn () => AutoLocality_Assert.assert_simproc_cancels_to ctxt + "AutoLocality_Test_Shapes.function_field_shape" "ffs_lookup" + "ffs_lookup (ffs_touch_counter k R) i" "ffs_lookup R i")] +\ + +subsection\Polymorphic records and operations\ + +datatype_record ('a, 'b) prc = + pl :: 'a + pr :: 'b + +locality_init for prc + +\\A fully polymorphic operation.\ +definition twiddle_pl :: \('a, 'b) prc \ ('a, 'b) prc\ where + \twiddle_pl R \ update_pl id R\ +\\An operation that partially instantiates the second type parameter to @{typ bool}.\ +definition set_pr_bool :: \bool \ ('a, bool) prc \ ('a, bool) prc\ where + \set_pr_bool v \ update_pr (\_. v)\ + +locality_lemma for prc: \twiddle_pl\ footprint [pl] . +locality_lemma for prc: \set_pr_bool\ footprint [pr] . + +text\Cancellation works on polymorphic and partially-instantiated terms alike.\ +lemma \pr (twiddle_pl X) = pr X\ by simp +lemma \pl (set_pr_bool v X) = pl X\ by simp +lemma \(pl :: ('a, bool) prc \ 'a) (set_pr_bool v X) = pl X\ by simp + +subsection\Known limitation: two record-typed arguments classify as an attribute\ + +text\A function @{typ \shp \ shp \ shp\} has two arguments that unify with the record type, so the +classifier's "exactly one matching argument" test (@{verbatim \is_fun_ty_on\}) fails and the function +is treated as an \<^emph>\attribute\ with two candidate record positions, not as an operation. This is a +genuine modelling boundary, recorded here as a checked fact rather than a bug. We assert the +classification at the ML level instead of registering it (registration would force a single record +position and is not the intended use).\ + +definition smerge :: \shp \ shp \ shp\ where + \smerge R S \ update_sa (\_. sa S) R\ + +ML\ + val ctxt = \<^context> + val (rec_ty, _) = prepare_rec_name ctxt "shp" + fun classify nm = + let val t = Syntax.read_term ctxt nm + val is_op = is_fun_ty_on rec_ty (Term.type_of t) + val idxs = case dest_attr_term ctxt rec_ty t of SOME (_, _, i) => i | NONE => [] + in (is_op, idxs) end + val _ = AutoLocality_Assert.run_suite "Shapes/classification" + [ \\A genuine single-record operation is classified as an operation.\ + ("sset_c is an operation", + fn () => AutoLocality_Assert.check "sset_c is_fun_ty_on" (#1 (classify "sset_c"))), + \\A single-record attribute with extra args is NOT an operation, one record position.\ + ("sa_between is an attribute at [1]", + fn () => AutoLocality_Assert.check "sa_between attr idxs=[1]" + (not (#1 (classify "sa_between")) andalso #2 (classify "sa_between") = [1])), + \\The two-record-argument function: not an operation, two candidate positions [0,1].\ + ("smerge classifies as attribute with idxs=[0,1]", + fn () => AutoLocality_Assert.check "smerge not op, idxs=[0,1]" + (not (#1 (classify "smerge")) andalso #2 (classify "smerge") = [0, 1])) ] +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Shapes_Wide.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Shapes_Wide.thy new file mode 100644 index 00000000..96f67cba --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Shapes_Wide.thy @@ -0,0 +1,225 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Shapes_Wide + imports AutoLocality_Test_Common +begin +(*>*) + +section\Body-shape coverage for \<^verbatim>\locality_lemma\\ + +text\This theory is a self-contained, fast-to-build regression suite that reproduces every +body-shape and invocation-shape in which @{verbatim \locality_lemma\} is used on a record with many +fields. It keeps the framework vetted inside the \<^verbatim>\Autogen\ session, which builds in +seconds. + +The shapes exercised here: +\<^enum> simple field projection / read (attribute); +\<^enum> simple single-field update, point-free / eta-reduced (operation); +\<^enum> constant single-field set, ignoring the old value (operation); +\<^enum> opaque single-field read-modify-write — body uses the OLD field value (operation); +\<^enum> conditional \<^verbatim>\if … then … else …\ body, attribute; +\<^enum> conditional body, operation that writes a DIFFERENT field per branch + (this is the \<^verbatim>\w_cond_write\ shape); +\<^enum> \<^verbatim>\let … in …\ body, operation (the \<^verbatim>\w_apply_policy\ shape); +\<^enum> \<^verbatim>\let\ body, attribute (arithmetic); +\<^enum> \<^verbatim>\let\ + tuple/\<^verbatim>\prod\ destructuring + multi-field update telescope (operation); +\<^enum> \<^verbatim>\case … of\ on a record field, attribute; +\<^enum> \<^verbatim>\case … of\ on a NON-record argument, operation; +\<^enum> multi-field update telescope (operation); +\<^enum> nested-record field update + delegation to another operation (operation); +\<^enum> attribute returning a list / set / bool / word / sum; +\<^enum> PARTIAL APPLICATION of a constant to an argument — two distinct partial applications of the + same head constant must get DISTINCT generated fact names (the + \<^verbatim>\w_apply_policy policy_a\ vs \<^verbatim>\w_apply_policy policy_b\ case); +\<^enum> over-approximated footprint (lists a field the body does not touch); +\<^enum> registration on an \<^verbatim>\abbreviation\ rather than a \<^verbatim>\definition\; +\<^enum> a wide (many-field) record, to exercise initialisation cost. + +We silence the tracer to keep the build log readable.\ + +declare [[locality_trace_level = 0]] + +subsection\A wide record (many fields, mixed types)\ + +text\21 fields, mixed scalar / list / option / nested-record types, so initialisation must prove the +linear lemmas against ~20 disjoint fields per operation — the cost hotspot.\ + +datatype_record inner_rec = + ir_x :: nat + ir_y :: nat + +datatype_record wide = + wf00 :: nat + wf01 :: \nat list\ + wf02 :: nat + wf03 :: \nat list\ + wf04 :: nat + wf05 :: \nat list\ + wf06 :: nat + wf07 :: \nat option\ + wf08 :: nat + wf09 :: \nat list\ + wf10 :: nat + wf11 :: nat + wf12 :: nat + wf13 :: nat + wf14 :: nat + wf15 :: nat + wf16 :: nat + wf17 :: nat + wf18 :: nat + wstate :: nat + winner :: \inner_rec\ + +subsubsection\Operations on \<^typ>\wide\ — all the operation body-shapes\ + +\\(2) simple single-field update, point-free / eta-reduced.\ +definition w_set00 :: \nat \ wide \ wide\ where \w_set00 v \ update_wf00 (\_. v)\ + +\\(3) constant single-field set.\ +definition w_clear00 :: \wide \ wide\ where \w_clear00 \ update_wf00 (\_. 0)\ + +\\(4) opaque single-field read-modify-write — uses the old value.\ +definition w_bump02 :: \nat \ wide \ wide\ where \w_bump02 k R \ update_wf02 (\old. old + k + wf02 R) R\ + +\\(6) conditional body, writes a DIFFERENT field per branch (the \w_cond_write\ shape).\ +definition w_cond_write :: \nat \ nat \ wide \ wide\ where + \w_cond_write a b R \ + if wstate R = 0 then update_wf00 (\_. a) R else update_wf02 (\_. b) R\ + +\\(7) let-body operation (the \w_apply_policy\ shape): bind locals, then a + multi-field update telescope. Parameterised by a function argument (so partial applications of it + below exercise shape 15).\ +definition w_apply_policy :: \(wide \ nat) \ wide \ wide\ where + \w_apply_policy policy R \ + let v = policy R in + let w = v + 1 in + update_wf01 (\_. [w]) (update_wf00 (\_. v) R)\ + +\\(9) let + tuple/prod destructuring + multi-field update telescope.\ +definition split_pair :: \nat \ nat \ nat\ where \split_pair k \ (k, k + 1)\ +definition w_split_set :: \nat \ wide \ wide\ where + \w_split_set k R \ + let (p, q) = split_pair k in + update_wf02 (\_. q) (update_wf00 (\_. p) R)\ + +\\(11) case on a NON-record argument; one branch delegates, the other returns the record unchanged.\ +datatype choice = Take | Leave +definition w_maybe :: \choice \ wide \ wide\ where + \w_maybe c R \ case c of Take \ w_clear00 R | Leave \ R\ + +\\(12) multi-field update telescope (sequential rewrites of several fields).\ +definition w_set_three :: \nat \ wide \ wide\ where + \w_set_three k R \ update_wf00 (\_. k) (update_wf02 (\_. k) (update_wf04 (\_. k) R))\ + +\\(13) nested-record field update + delegation to another operation.\ +definition w_nested :: \nat \ wide \ wide\ where + \w_nested k R \ w_clear00 (update_winner (\i. update_ir_x (\_. k) i) R)\ + +locality_lemma for wide: \w_set00\ footprint [wf00] . +locality_lemma for wide: \w_clear00\ footprint [wf00] . +locality_lemma for wide: \w_bump02\ footprint [wf02] . +locality_lemma for wide: \w_cond_write\ footprint [wstate, wf00, wf02] . +locality_lemma for wide: \w_split_set\ footprint [wf00, wf02] . +locality_lemma for wide: \w_maybe\ footprint [wf00] . +locality_lemma for wide: \w_set_three\ footprint [wf00, wf02, wf04] . +locality_lemma for wide: \w_nested\ footprint [wf00, winner] . + +text\The let-body operation, exercised both bare and via TWO distinct partial applications of the +same head constant — these must get distinct fact names (shape 15).\ + +definition policy_a :: \wide \ nat\ where \policy_a R \ wf04 R\ +definition policy_b :: \wide \ nat\ where \policy_b R \ wf06 R + 1\ + +locality_lemma for wide: \w_apply_policy policy_a\ footprint [wf00, wf01, wf04] . +locality_lemma for wide: \w_apply_policy policy_b\ footprint [wf00, wf01, wf06] . + +subsubsection\Attributes on \<^typ>\wide\ — all the attribute body-shapes\ + +\\(1) simple field projection.\ +definition w_read00 :: \wide \ nat\ where \w_read00 R \ wf00 R\ + +\\(5) conditional attribute.\ +definition w_cond_read :: \wide \ nat\ where + \w_cond_read R \ if wstate R = 0 then wf00 R else wf02 R\ + +\\(8) let-body attribute (arithmetic).\ +definition w_let_avg :: \wide \ nat\ where + \w_let_avg R \ let a = wf00 R in let b = wf02 R in (a + b + 1) div 2\ + +\\(10) case on a record field, attribute returning a list.\ +definition w_case_list :: \wide \ nat list\ where + \w_case_list R \ case wf07 R of None \ [] | Some n \ n # wf01 R\ + +\\(14a) attribute returning a LIST (concatenation of two field reads).\ +definition w_all_list :: \wide \ nat list\ where \w_all_list R \ wf01 R @ wf03 R\ + +\\(14b) attribute returning a SET.\ +definition w_set_attr :: \wide \ nat set\ where \w_set_attr R \ {wf00 R} \ set (wf01 R)\ + +\\(14c) attribute returning a BOOL (predicate).\ +definition w_pred :: \wide \ bool\ where \w_pred R \ wf00 R > 0 \ wf02 R \ 10\ + +\\(14d) attribute reading a field as a function then existential (field used as a map).\ +definition w_exists :: \wide \ bool\ where \w_exists R \ \x \ set (wf01 R). x > wf00 R\ + +locality_lemma for wide: \w_read00\ footprint [wf00] . +locality_lemma for wide: \w_cond_read\ footprint [wstate, wf00, wf02] . +locality_lemma for wide: \w_let_avg\ footprint [wf00, wf02] . +locality_lemma for wide: \w_case_list\ footprint [wf07, wf01] . +locality_lemma for wide: \w_all_list\ footprint [wf01, wf03] . +locality_lemma for wide: \w_set_attr\ footprint [wf00, wf01] . +locality_lemma for wide: \w_pred\ footprint [wf00, wf02] . +locality_lemma for wide: \w_exists\ footprint [wf00, wf01] . + +\\(16) over-approximated footprint: body only reads wf00, but we declare wf00, wf02.\ +definition w_over :: \wide \ nat\ where \w_over R \ wf00 R + 1\ +locality_lemma for wide: \w_over\ footprint [wf00, wf02] . + +\\(17) registration on an abbreviation rather than a definition. The abbreviation must denote a + term that is not already a registered attribute (an abbreviation is transparent, so aliasing an + already-registered attribute would just re-register it and collide); here it concatenates two + field reads directly.\ +abbreviation w_abbrev :: \wide \ nat list\ where \w_abbrev R \ wf05 R @ wf09 R\ +locality_lemma for wide: \w_abbrev\ footprint [wf05, wf09] . + +subsection\Assertions: the framework actually fired and the simproc cancels\ + +text\Object-level cancellations a downstream proof would rely on — each must close by plain +@{term \simp\} (which runs the default-on locality cancellation simprocs).\ + +lemma \w_read00 (w_bump02 k R) = w_read00 R\ by simp +lemma \w_all_list (w_set00 v R) = w_all_list R\ by simp +lemma \w_pred (update_wf04 (\_. z) R) = w_pred R\ by simp +lemma \w_let_avg (update_wf04 (\_. z) (update_wf05 (\_. zs) R)) = w_let_avg R\ by simp + +text\The generated linear facts exist for a representative operation and attribute, confirming +registration ran (footprint registered) rather than silently failing.\ + +ML\ + val ctxt = \<^context> + val rid = "AutoLocality_Test_Shapes_Wide_wide" + val _ = AutoLocality_Assert.run_suite "ShapesWide/registration" + [ ("cond-write op lemmas", fn () => AutoLocality_Assert.assert_op_lemmas ctxt rid "w_cond_write"), + ("let-body op lemmas", fn () => AutoLocality_Assert.assert_op_lemmas ctxt rid "w_split_set"), + ("attr w_all_list lemma", fn () => AutoLocality_Assert.assert_attr_lemmas ctxt rid "w_all_list" 0), + ("no quadratic bundle", fn () => AutoLocality_Assert.assert_no_quadratic ctxt rid) ] +\ + +text\The two partial applications of \<^const>\w_apply_policy\ must have produced DISTINCT fact bundles +(shape 15 — the duplicate-fact regression). We check both names resolve to a non-empty fact.\ + +ML\ + val ctxt = \<^context> + val rid = "AutoLocality_Test_Shapes_Wide_wide" + fun core_of nm = rid ^ "_local_op_" ^ nm ^ "_core" + val _ = AutoLocality_Assert.run_suite "ShapesWide/partial-application-distinct" + [ ("policy_a fact present", fn () => AutoLocality_Assert.assert_fact ctxt (core_of "w_apply_policy_policy_a")), + ("policy_b fact present", fn () => AutoLocality_Assert.assert_fact ctxt (core_of "w_apply_policy_policy_b")) ] +\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Wide.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Wide.thy new file mode 100644 index 00000000..5808c602 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Wide.thy @@ -0,0 +1,297 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Wide + imports AutoLocality_Test_Common +begin +(*>*) + +section\Wide-record initialisation cost\ + +text\This theory is a regression guard for the cost of the \<^emph>\first\ @{verbatim \locality_lemma\} on a +record with many fields. That first command implicitly runs @{verbatim \locality_init\}, which +registers a cancellation simproc and proves the three linear lemmas (commutativity, disjointness, +local action) for \<^emph>\every\ field update of the record. The record's @{verbatim \record_simps\} set +grows quadratically in the number of fields, so a naive @{verbatim \auto\}-based discharge of those +lemmas made initialisation scale very badly: a ~20-field record took tens of seconds, with the whole +cost attributed (confusingly) to whichever lemma happened to be stated first. + +The record below has 21 fields of mixed scalar and list type. \<^verbatim>\wide_concat_lists\ +has the shape of the attribute that originally exposed the problem: a projection-only attribute +reading two list-typed fields and concatenating them (footprint of two fields, disjoint from the +rest). The timing guards below assert that initialisation-plus-first-lemma, and each subsequent +lemma, complete well within budget. The bounds are generous tripwires, not tight +benchmarks - they exist to catch an accidental return to super-linear initialisation, not to pin a +particular wall-clock number.\ + +text\We silence the locality tracer (@{verbatim \locality_trace_level = 0\}): initialising a wide +record fires the per-field simproc-creation trace ~20 times and would otherwise dominate the build +log. Cancellation behaviour is unaffected.\ + +declare [[locality_trace_level = 0]] + +datatype_record wide = + w_f00 :: nat + w_f01 :: nat + w_f02 :: nat + w_f03 :: \nat list\ + w_f04 :: \nat list\ + w_f05 :: \nat list\ + w_f06 :: \nat list\ + w_f07 :: nat + w_f08 :: nat + w_f09 :: nat + w_f10 :: nat + w_f11 :: nat + w_f12 :: nat + w_f13 :: nat + w_f14 :: nat + w_f15 :: \nat list\ + w_f16 :: \nat list\ + w_f17 :: nat + w_f18 :: nat + w_f19 :: nat + w_f20 :: nat + +text\The attribute that originally exposed the cost: a projection-only attribute reading two +list-typed fields and concatenating them. Footprint = two of the list-typed fields; this is +disjoint from the other ~19 fields, so initialisation must prove a commutativity and disjointness +lemma against each of them.\ + +definition wide_concat_lists :: \wide \ nat list\ where + \wide_concat_lists R \ w_f05 R @ w_f15 R\ + +text\The first locality lemma on \<^typ>\wide\: this implicitly triggers initialisation of all field +updates. With the optimised @{verbatim \HOL_basic_ss\}-based discharge this is fast; the timing guard +below pins the regression.\ + +locality_lemma for wide: wide_concat_lists footprint [w_f05, w_f15] . + +text\A couple more attributes on the same record. Initialisation has already happened, so these only +pay for their own lemmas.\ + +definition wide_f01_plus :: \wide \ nat\ where + \wide_f01_plus R \ w_f01 R + 1\ +locality_lemma for wide: wide_f01_plus footprint [w_f01] . + +definition wide_f20_f00_sum :: \wide \ nat\ where + \wide_f20_f00_sum R \ w_f20 R + w_f00 R\ +locality_lemma for wide: wide_f20_f00_sum footprint [w_f20, w_f00] . + +text\An opaque operation that writes a field from its old value: the local-action lemma for such an +operation genuinely needs record extensionality, so it exercises the @{verbatim \rec.expand\} fallback +of @{verbatim \locality_local_action_tac\} rather than the pure-rewriting fast path.\ + +definition wide_bump_f01 :: \nat \ wide \ wide\ where + \wide_bump_f01 k R \ update_w_f01 (\old. old + k + w_f01 R) R\ +locality_lemma for wide: \wide_bump_f01\ footprint [w_f01] . + +definition wide_bump_f02 :: \nat \ wide \ wide\ where + \wide_bump_f02 k R \ update_w_f02 (\old. old + k + w_f02 R) R\ +locality_lemma for wide: \wide_bump_f02\ footprint [w_f02] . + +definition wide_take_f05 :: + \nat \ nat list \ wide \ wide\ where + \wide_take_f05 n xs R \ + update_w_f05 (\_. take n xs) R\ +locality_lemma for wide: \wide_take_f05\ footprint [w_f05] . + +definition wide_drop_f05 :: + \nat list \ nat \ wide \ wide\ where + \wide_drop_f05 xs n R \ + update_w_f05 (\_. drop n xs) R\ +locality_lemma for wide: \wide_drop_f05\ footprint [w_f05] . + +subsection\Cancellation still works on the wide record\ + +text\Object-level sanity: the projection attribute cancels disjoint operations under plain +@{term \simp\}, including across the opaque operation (which touches only \<^term>\w_f01\).\ + +lemma \wide_concat_lists (wide_bump_f01 k (update_w_f00 s R)) = wide_concat_lists R\ + by simp + +lemma \w_f20 (wide_bump_f01 k (update_w_f00 (\_. s) R)) = w_f20 R\ + by simp + +subsection\Buried cancellation across an overlapping update pipeline\ + +text\The operation cancelled above is already adjacent to the attribute. The expensive regression +has a different shape: two cancellable opaque operations are separated by a long pipeline of +other opaque operations that overlap the attribute. The inner operation must first commute +outwards across that pipeline before both operations reach the attribute. + +The synthetic goals below preserve that shape on this wide record. The blockers alternate between +two registered operations with distinct argument orders, and every application has fresh +arguments, so neither theorem deduplication nor term sharing can collapse the pipeline. Unlike raw +field updates, the blockers carry self-referential local-action certificates, matching the opaque +operations whose normalisation exposed the regression. The depth-16 case took 11.715 seconds +before the fix. The permanent four-second gate also checks that the planner derives the two +operation-pair swaps directly instead of rebuilding three whole-telescope record simpsets or +falling back to repeated whole-term rewrites.\ + +ML\ +local + +open AutoLocality_Instrumentation + +val base_context = \<^context> +val attribute = Syntax.read_term base_context "wide_concat_lists" +val blockers = + [ Syntax.read_term base_context "wide_take_f05", + Syntax.read_term base_context "wide_drop_f05" ] +val outer_front = Syntax.read_term base_context "wide_bump_f01" +val inner_front = Syntax.read_term base_context "wide_bump_f02" +val state = Syntax.read_term base_context "R :: wide" +val list_type = HOLogic.listT HOLogic.natT + +fun blocked n body = + fold (fn i => fn inner => + let + val blocker = nth blockers (i mod length blockers) + val salt = Free ("n" ^ Int.toString i, HOLogic.natT) + val values = Free ("xs" ^ Int.toString i, list_type) + in + if i mod length blockers = 0 + then blocker $ salt $ values $ inner + else blocker $ values $ salt $ inner + end) + (1 upto n) body + +fun buried_hoist_goal n = + let + val inner_body = + inner_front $ Free ("inner_k", HOLogic.natT) $ state + val lhs = + outer_front + $ Free ("outer_k", HOLogic.natT) + $ blocked n inner_body + val rhs = blocked n state + in + HOLogic.mk_Trueprop + (HOLogic.mk_eq + (attribute $ lhs, attribute $ rhs)) + end + +fun run_buried_hoist n = + let + val (run_id, context) = start_run base_context + val started = Timing.start () + val outcome = + Exn.capture + (fn () => + Timeout.apply (Time.fromSeconds 4) + (fn () => + Goal.prove context [] [] (buried_hoist_goal n) + (fn {context, ...} => + asm_full_simp_tac context 1)) ()) () + val timing = Timing.result started + val snapshot = + (case freeze_run run_id of + SOME result => result + | NONE => error "Missing buried-hoist instrumentation snapshot") + val dropped = drop_run run_id + val _ = + writeln + ("Wide/buried-hoist depth " ^ Int.toString n ^ ": " + ^ Timing.message timing + ^ "; planner.requests=" + ^ IntInf.toString (snapshot_counter snapshot Planner_Requests) + ^ "; planner.swap_applications=" + ^ IntInf.toString + (snapshot_counter snapshot Planner_Swap_Applications) + ^ "; planner.cancellations=" + ^ IntInf.toString (snapshot_counter snapshot Planner_Cancellations) + ^ "; planner.root_rewrites=" + ^ IntInf.toString (snapshot_counter snapshot Planner_Root_Rewrites) + ^ "; record.simpset_builds=" + ^ IntInf.toString (snapshot_counter snapshot Record_Simpset_Builds)) + val _ = Exn.release outcome + val _ = AutoLocality_Assert.run_suite + ("Wide/buried-hoist depth " ^ Int.toString n) + [ ("planner entered", + fn () => AutoLocality_Assert.check "planner entered" + (snapshot_counter snapshot Planner_Requests > 0)), + ("buried operation cancelled", + fn () => AutoLocality_Assert.check "buried operation cancelled" + (snapshot_counter snapshot Planner_Cancellations = 2)), + ("root cancellation applied", + fn () => AutoLocality_Assert.check "root cancellation applied" + (snapshot_counter snapshot Planner_Root_Rewrites = 2)), + ("two operation-pair swaps derived", + fn () => AutoLocality_Assert.check + "two operation-pair swaps derived" + (snapshot_counter snapshot Planner_Swaps = 2)), + ("all buried crossings use exact swaps", + fn () => AutoLocality_Assert.check + "sixteen exact adjacent swaps applied" + (snapshot_counter snapshot Planner_Swap_Applications = 16)), + ("avoids whole-telescope simpsets", + fn () => AutoLocality_Assert.check + "at most two pair-specific record simpsets" + (snapshot_counter snapshot Record_Simpset_Builds <= 2)), + ("avoids fallback rescans", + fn () => AutoLocality_Assert.check "no fallback rescans" + (snapshot_counter snapshot Fallback_Requests = 0 + andalso snapshot_counter snapshot Planner_Root_Rescans = 0 + andalso + snapshot_counter snapshot Fallback_Whole_Term_Rewrites = 0)), + ("instrumentation run freezes drained", + fn () => AutoLocality_Assert.check "clean freeze" + (snapshot_phase snapshot = Frozen + andalso snapshot_active_callbacks snapshot = 0 + andalso snapshot_async_leases snapshot = 0)), + ("instrumentation run drops", + fn () => AutoLocality_Assert.check "clean drop" dropped) ] + in + #elapsed timing + end + +in + +val _ = run_buried_hoist 16 + +end +\ + +subsection\Timing guards: initialisation must not regress to super-linear\ + +text\Each guard re-states a fresh attribute on a fresh wide record inside its own @{verbatim \context\} +so that we measure a full initialisation-plus-first-lemma, then checks it cancels within budget. The +4s budget is a tripwire: the optimised path finishes this in well under a second, whereas the old +@{verbatim \auto\}-based initialisation took tens of seconds on a record this wide.\ + +ML\ + val ctxt = \<^context> + val _ = AutoLocality_Assert.run_suite "Wide/cancellation-within-budget" + [ ("concat over disjoint op", fn () => + AutoLocality_Assert.check "concat/bump" + (AutoLocality_Assert.cancels_within ctxt 4000 + "wide_concat_lists (wide_bump_f01 k (update_w_f00 s R)) = wide_concat_lists R")), + ("projection over deep disjoint nest", fn () => + AutoLocality_Assert.check "f20/deep" + (AutoLocality_Assert.cancels_within ctxt 4000 + "w_f20 (update_w_f01 (\_. a) (update_w_f02 (\_. b) (update_w_f00 (\_. c) R))) = w_f20 R")), + ("multi-field projection", fn () => + AutoLocality_Assert.check "f20_f00_sum/disjoint" + (AutoLocality_Assert.cancels_within ctxt 4000 + "wide_f20_f00_sum (update_w_f01 (\_. a) R) = wide_f20_f00_sum R")) ] +\ + +text\The three linear lemmas exist for the registered operations and attributes, confirming +initialisation actually ran and registered footprints (rather than silently skipping a field whose +local-action proof failed - the failure mode that a @{verbatim \SOLVED'\}-less local-action tactic +would produce on the opaque operation).\ + +ML\ + val ctxt = \<^context> + val rec_id = "AutoLocality_Test_Wide_wide" + val _ = AutoLocality_Assert.run_suite "Wide/lemmas-registered" + [ ("concat attr lemma", fn () => AutoLocality_Assert.assert_attr_lemmas ctxt rec_id "wide_concat_lists" 0), + ("opaque op lemmas", fn () => AutoLocality_Assert.assert_op_lemmas ctxt rec_id "wide_bump_f01"), + ("no quadratic bundle", fn () => AutoLocality_Assert.assert_no_quadratic ctxt rec_id) ] +\ + +(*<*) +end +(*>*) diff --git a/Autogen/Autogen.thy b/Autogen/Autogen.thy index 6fa332b9..176af9f0 100644 --- a/Autogen/Autogen.thy +++ b/Autogen/Autogen.thy @@ -2,11 +2,9 @@ SPDX-License-Identifier: MIT *) theory Autogen - imports AutoLens + imports AutoCommon - AutoLocality_Test0 - AutoLocality_Test1 - AutoLocality_Test2 + AutoLens AutoLocality begin -end \ No newline at end of file +end diff --git a/Autogen/README.md b/Autogen/README.md new file mode 100644 index 00000000..7546d03a --- /dev/null +++ b/Autogen/README.md @@ -0,0 +1,496 @@ +# AutoLocality + +--- TODO: This should be a machine-checked theory file, not Markdown. --- + +AutoLocality is AutoCorrode's automation for reasoning about functions on +records. Its purpose is simple: The user states once which record fields a function can +observe or change, then let Isabelle remove state updates that cannot affect +the current observation. + +For example, if `set_counter` touches only `counter` and `in_mode` reads only +`mode`, then AutoLocality lets the ordinary simplifier prove: + +```isabelle +lemma ‹in_mode (set_counter n R) = in_mode R› + by simp +``` + +A simple approach to achieve this is to pre-generate such a "cancellation lemmas" +for every pair of functions with disjoint footprint. This, however, is inefficient +from a complexity and memory usage perspective since the number of such cancellation +lemmas is quadratic in the number of operations. + +The present implementation does not populate the theory with every possible pairwise +commutativity and cancellation theorem. Instead, it stores a linear set of checked +"certificates for each registered function and constructs the cancellation and/or +commutativity lemmas at simplification time using a simproc. For a fixed record width, this +keeps declaration cost and theory data proportional to the number of +registered functions rather than the number of pairs of functions. + +The executable implementation and its design notes are in +[AutoLocality.thy](AutoLocality.thy); the regression theories live under +`AutoLocality_Tests/`. + +## The problem AutoLocality solves + +Large state models commonly contain: + +- **operations**, which return an updated record; +- **attributes**, which observe a record and return another type; and +- long pipelines of operations under an attribute. + +Each operation and attribute has a **footprint**. For an attribute, the +footprint contains every field it reads. For an operation, it contains every +field it reads or writes. The combined read-and-write interpretation matters: +two disjoint operation footprints are sufficient to show that the operations +commute, while an operation disjoint from an attribute cannot change the +attribute's result. + +Suppose: + +```isabelle +attr (outer (irrelevant R)) +``` + +`irrelevant` can be removed when: + +1. its footprint is disjoint from the footprint of `attr`; and +2. it can cross every operation between itself and `attr`. + +AutoLocality discovers that cancellation at simplification time. It can keep +operations that matter, commute an irrelevant operation past compatible +blockers, and then cancel it at the attribute. A failed or inapplicable +attempt simply leaves the term unchanged. + +The user remains responsible for declaring the footprint. AutoLocality proves +certificates for that declaration before registering it, so an incorrect +under-approximation normally fails at the `locality_lemma` proof. A safe +over-approximation is allowed, but may prevent valid cancellations. + +## Quick start + +Import `AutoLocality`, define the state functions, and register their +footprints: + +```isabelle +theory Example + imports AutoLocality +begin + +datatype_record machine_state = + mode :: nat + counter :: nat + +definition set_counter :: + ‹nat ⇒ machine_state ⇒ machine_state› where + ‹set_counter n ≡ update_counter (λ_. n)› + +definition set_mode :: + ‹nat ⇒ machine_state ⇒ machine_state› where + ‹set_mode n ≡ update_mode (λ_. n)› + +definition in_mode :: ‹machine_state ⇒ bool› where + ‹in_mode R ≡ mode R > 0› + +locality_lemma for machine_state: + ‹set_counter› footprint [counter] . + +locality_lemma for machine_state: + ‹set_mode› footprint [mode] . + +locality_lemma for machine_state: + ‹in_mode› footprint [mode] . + +lemma ‹in_mode (set_counter n R) = in_mode R› + by simp + +end +``` + +The first `locality_lemma` initializes the record automatically. Explicit +`locality_init` is useful when the locality registrations for generated field +selectors and updaters must exist before any user-defined function is +registered. + +Plain `simp` includes AutoLocality cancellation by default. `simp only` +deliberately starts without the ambient simprocs, so add +`[[locality_cancel]]` when cancellation is wanted: + +```isabelle +lemma ‹in_mode (set_counter n R) = in_mode R› + by (simp only: [[locality_cancel]]) +``` + +## Concepts and terminology + +### Operations + +An operation has exactly one argument matching the record type and returns +that record type, possibly with additional non-record arguments: + +```isabelle +set_counter :: nat ⇒ machine_state ⇒ machine_state +``` + +Its footprint includes all fields that its result may depend on or modify. + +### Attributes + +An attribute observes one or more arguments matching the record type. In +ordinary use it returns a non-record result: + +```isabelle +in_mode :: machine_state ⇒ bool +between :: nat ⇒ machine_state ⇒ nat ⇒ bool +related :: machine_state ⇒ machine_state ⇒ bool +``` + +Each record argument is registered separately when an attribute observes more +than one record. + +The operation classifier requires exactly one record-typed argument and a +record result. A function that returns the record but has multiple +record-typed arguments therefore falls through to the attribute path. This is +a known modelling boundary, not support for multi-record state updates. + +### Generated field operations + +`locality_init` registers each generated record selector as an attribute and +each generated record updater as an operation. Users therefore do not need +`locality_lemma` declarations for ordinary field selectors and updaters. + +## Commands and attributes + +### `locality_init` + +Syntax: + +```isabelle +locality_init for record_type +``` + +This command: + +- registers the record's generated selectors and updaters; +- creates the record's `_locality_facts` named-theorem bundle; and +- declares the required named cancellation dispatchers in the active local + theory. + +Initialization is idempotent. It is also performed implicitly by the first +`locality_lemma` for a record. + +### `locality_lemma` + +General syntax: + +```isabelle +locality_lemma for record_type + [(no_proof)] + [fact_attributes]: + term [record_match_index] + footprint [field_1, ..., field_n] + proof +``` + +The common forms are: + +```isabelle +locality_lemma for machine_state: + ‹set_counter› footprint [counter] . + +locality_lemma for machine_state: + ‹in_mode› footprint [mode] . +``` + +AutoLocality classifies the term from its type, generates the linear +certificates needed for later proof construction, and first attempts to prove +them automatically. A trailing `.` is enough when that attempt succeeds. If +goals remain, continue with an ordinary Isar proof. + +Use `(no_proof)` to suppress the initial automatic attempt: + +```isabelle +locality_lemma for machine_state (no_proof): + ‹manual_operation› footprint [counter] + by (auto simp add: manual_operation_def) +``` + +`record_match_index` selects among the term's record-typed arguments, not +among all arguments. It defaults to `0`. Thus an attribute whose sole record +argument is its second ordinary argument still uses `[0]`, while an attribute +with two record arguments uses `[0]` and `[1]` in separate declarations: + +```isabelle +definition related :: + ‹machine_state ⇒ machine_state ⇒ bool› where + ‹related L R ≡ mode L < counter R› + +locality_lemma for machine_state: + ‹related› [0] footprint [mode] . + +locality_lemma for machine_state: + ‹related› [1] footprint [counter] . +``` + +The registered term may be a typed or partial application. Distinct rigid +prefixes can have distinct footprints: + +```isabelle +locality_lemma for machine_state: + ‹policy_attribute mode_policy› footprint [mode] + by (auto simp add: policy_attribute_def mode_policy_def) +``` + +Inside a locale, register locale-defined constants from a `context` re-entry +after their definitions are complete, and use their short names. The +registration is morphism-aware and follows locale interpretations. The +dispatcher declaration stays with that owning local theory; it is not +installed by leaving the locale, modifying the background theory, and +re-entering the locale. + +When `[fact_attributes]` is omitted, generated public certificates are added +to the record's `_locality_facts` bundle. Supplying attributes directs +the generated facts to those attributes instead; the explicit attributes +replace, rather than supplement, the default bundle annotation. + +### Automatic cancellation with `simp` + +Cancellation is enabled in the ambient simpset: + +```isabelle +lemma ‹in_mode (set_counter n R) = in_mode R› + by simp +``` + +The same applies to nested operation pipelines. AutoLocality removes only +operations that are irrelevant to the observation and can be moved across +the intervening operations. + +This automation is for an **attribute over operations**. It does not +arbitrarily reorder a bare term such as `op_a (op_b R)`. + +### `[[locality_cancel]]` + +This fact attribute enables cancellation and restores any registered local +dispatchers missing from the current simpset. The restoration matters for +`simp only:`, which clears the ambient simpset before processing its explicit +arguments. + +Typical uses: + +```isabelle +by (simp only: [[locality_cancel]]) +``` + +or: + +```isabelle +context + notes [[locality_cancel]] +begin + +... + +end +``` + +It is usually unnecessary with plain `simp`, because cancellation is enabled +by default. Repeated activation is idempotent: it does not duplicate raw +simprocs. + +### `[[locality_no_cancel]]` + +This fact attribute disables AutoLocality cancellation in its scope: + +```isabelle +lemma ‹in_mode (set_counter n R) = in_mode R› + supply [[locality_no_cancel]] + by (simp add: in_mode_def set_counter_def) +``` + +This is useful for controls, diagnostics, and proofs whose own rewrite set +must determine the normal form. It changes a context configuration flag; it +does not remove inherited simproc declarations. Disabled callbacks return +immediately. + +### `[[locality_autocancellation ...]]` + +Syntax: + +```isabelle +[[locality_autocancellation + operation attribute relative_record_index]] +``` + +The record type is inferred from the operation and indexed-attribute +registrations. If the same polymorphic constants are registered for more than +one record, disambiguate explicitly: + +```isabelle +[[locality_autocancellation + (record_type) operation attribute relative_record_index]] +``` + +This derives and returns one generalized operation/attribute cancellation +theorem without registering or caching it: + +```isabelle +lemma ‹in_mode (set_counter n R) = in_mode R› + by (rule [[locality_autocancellation + set_counter in_mode 0]]) +``` + +It is most useful in `simp only` proofs that need one explicit cancellation: + +```isabelle +by (simp only: + [[locality_autocancellation + set_counter in_mode 0]]) +``` + +Here the index is the attribute's record argument position relative to the +arguments remaining after any prefix supplied by the context. Locale +parameters already supplied by the context do not count. This differs from +`locality_lemma`'s `record_match_index`, which selects among record-typed +arguments. + +The operation and attribute positions accept named constants, not arbitrary +terms. An explicit fact therefore cannot directly name a rigid partial +application such as `policy_attribute mode_policy`; use ambient `simp` or +introduce a named wrapper constant for that case. + +Ordinary proofs should prefer plain `simp`; needing this attribute routinely +is a sign that cancellation is being requested in a restricted simpset or +that automatic dispatcher coverage should be investigated. + +### `[[locality_autocommutativity ...]]` + +Syntax: + +```isabelle +[[locality_autocommutativity + operation_a operation_b]] +``` + +The record type is inferred from the records carrying matching registrations +for both operations. If that intersection contains more than one record, +disambiguate explicitly: + +```isabelle +[[locality_autocommutativity + (record_type) operation_a operation_b]] +``` + +This derives and returns one generalized theorem saying that two registered +operations commute: + +```isabelle +lemma + ‹set_mode m (set_counter n R) = + set_counter n (set_mode m R)› + by (rule [[locality_autocommutativity + set_mode set_counter]]) +``` + +It can also be named or supplied to the simplifier: + +```isabelle +lemmas mode_counter_commute = + [[locality_autocommutativity + set_mode set_counter]] + +lemma ... + by (simp add: + [[locality_autocommutativity + set_mode set_counter]]) +``` + +The attribute fails if the registrations are missing or the requested +commutativity cannot be proved. It does not alter the ambient simpset. + +Both operation positions accept named constants. To request commutativity for +a rigid partial application, introduce a named wrapper constant. + +### `locality_check` + +Syntax: + +```isabelle +locality_check +locality_check for record_type +``` + +This diagnostic scans visible operations and attributes involving the +selected record, prints whether each has footprint information, and warns +about unregistered user constants. With no record argument, it checks every +record already known to AutoLocality. + +It does not create registrations. + +### `print_locality_data` + +Syntax: + +```isabelle +print_locality_data +print_locality_data for record_type +``` + +This prints registered terms, selected record arguments, and footprints. Use +it to inspect typed or partial registrations and to confirm which record slot +was selected. + +## Diagnostic configuration + +Tracing is disabled by default. Positive values increase verbosity: + +```isabelle +declare [[locality_trace_level = 1]] +``` + +Declaration-time proof timing is also off by default: + +```isabelle +declare [[locality_timing = true]] +``` + +`locality_timing` reports the phases used to establish registration +certificates. It is a diagnostic setting, not a benchmarking interface. + +## What to expect from the simplifier + +AutoLocality should: + +- cancel disjoint operations under registered attributes with plain `simp`; +- preserve operations whose footprints overlap the attribute; +- cross an intervening operation only when the required commutativity is + proved; +- preserve extra arguments, including arguments after function-valued record + selectors; +- respect typed partial applications and locale interpretations; and +- decline safely when no justified rewrite exists. + +AutoLocality does not: + +- infer footprints from definitions; +- automatically normalize every operation/operation ordering; +- make overlapping footprints commute; +- add on-demand pairwise theorems permanently to the context; or +- use a process-global theorem cache. + +## Further examples + +The most direct executable examples are: + +- [AutoLocality_Test_Cancel.thy](AutoLocality_Tests/AutoLocality_Test_Cancel.thy) + for plain-`simp` cancellation; +- [AutoLocality_B0_Base.thy](AutoLocality_Tests/AutoLocality_B0_Base.thy) + for explicit cancellation and commutativity facts; +- [AutoLocality_Test_Shapes.thy](AutoLocality_Tests/AutoLocality_Test_Shapes.thy) + for argument positions, polymorphism, and function-valued selectors; +- [AutoLocality_Test_Locale.thy](AutoLocality_Tests/AutoLocality_Test_Locale.thy) + for locale declarations and interpretations; +- [AutoLocality_Test_Perf.thy](AutoLocality_Tests/AutoLocality_Test_Perf.thy) + for deep-telescope structural performance guards; and +- [AutoLocality_Test_Wide.thy](AutoLocality_Tests/AutoLocality_Test_Wide.thy) + for wide records and the counted buried-hoist regression. diff --git a/Autogen/ROOT b/Autogen/ROOT index 98e39dd7..2d55dd24 100644 --- a/Autogen/ROOT +++ b/Autogen/ROOT @@ -8,6 +8,37 @@ session Autogen = HOL + AutoLens AutoLocality Autogen - AutoLocality_Test0 - AutoLocality_Test1 - AutoLocality_Test2 + +session AutoLocality_Tests in "AutoLocality_Tests" = Autogen + + options [document = false] + sessions + Crush + theories + AutoLocality_Test3 + AutoLocality_Test_Common + AutoLocality_Test_Linear + AutoLocality_Test_Cancel + AutoLocality_Test_Errors + AutoLocality_Test_Locale + AutoLocality_Test_Contexts + AutoLocality_Test_Polymorphic + AutoLocality_Test_Diamond_Base + AutoLocality_Test_Diamond_Left + AutoLocality_Test_Diamond_Right + AutoLocality_Test_Diamond + AutoLocality_Test_Boundaries + AutoLocality_Test_Record_Extension + AutoLocality_Test_Shapes + AutoLocality_Test_Perf + AutoLocality_Test_Wide + AutoLocality_Test_Shapes_Wide + AutoLocality_Test_Matrix + AutoLocality_Test_Matrix_Locale + AutoLocality_B0_All + AutoLocality_B0_Conflict_Left + AutoLocality_B0_Conflict_Right + AutoLocality_B0_Automation + AutoLocality_B0_Crush_All + AutoLocality_C1_Locale_Retention + AutoLocality_C1_Instrumentation + AutoLocality_C1_Counters diff --git a/Makefile b/Makefile index c1d05feb..15404a28 100644 --- a/Makefile +++ b/Makefile @@ -8,7 +8,8 @@ ###################################################################### .DEFAULT_GOAL: jedit -.PHONY: register-afp-components build jedit tutorial \ +.PHONY: register-afp-components build autolocality-tests \ + autolocality-stress jedit tutorial \ build-ic2 ic2 ic2-status ic2-stop # Set this to the directory containing the Isabelle2025-2 binary @@ -47,7 +48,16 @@ register-afp-components: $(ISABELLE_HOME)/isabelle components -u $(AFP_COMPONENT_BASE)/Word_Lib build: register-afp-components - $(ISABELLE_HOME)/isabelle build $(ISABELLE_FLAGS) -d . AutoCorrode + $(ISABELLE_HOME)/isabelle build $(ISABELLE_FLAGS) -d . \ + AutoCorrode AutoLocality_Tests + +autolocality-tests: register-afp-components + $(ISABELLE_HOME)/isabelle build $(ISABELLE_FLAGS) -d . AutoLocality_Tests + +# Kept as a compatibility entry point. The unified test session includes +# the former locale-retention stress theory. +autolocality-stress: register-afp-components + $(ISABELLE_HOME)/isabelle build $(ISABELLE_FLAGS) -d . AutoLocality_Tests # Build the slide-deck tutorial in tutorial/. Inherits the AutoCorrode # parent heap, so run `make build` first if it isn't built yet. diff --git a/README.md b/README.md index 0da5be04..2395a159 100644 --- a/README.md +++ b/README.md @@ -96,7 +96,12 @@ Crush is a family of highly customizable and scalable tactics for reasoning in s ### [Autogen](https://awslabs.github.io/AutoCorrode/Unsorted/AutoCorrode/Autogen.Autogen.html) -Autogen facilitates pure reasoning about functions on records: Users can annotate functions with their footprint -- the set of record fields they depend on -- and have footprint-based commutativity relations derived automatically. See [Autogen/AutoLocality_Test0.thy](https://awslabs.github.io/AutoCorrode/Unsorted/AutoCorrode/Autogen.AutoLocality_Test0.html) for an example. +Autogen facilitates pure reasoning about functions on records: users annotate +functions with their footprints, and AutoLocality uses those declarations to +cancel irrelevant state operations during simplification. See the +[AutoLocality guide](Autogen/README.md) for motivation, commands, and +examples. The executable regression theories live under +`Autogen/AutoLocality_Tests/`. ### [Byte_Level_Encoding](https://awslabs.github.io/AutoCorrode/Unsorted/AutoCorrode/Byte_Level_Encoding.Byte_Level_Encoding.html) diff --git a/tutorial/Tutorial_HoareWorked.thy b/tutorial/Tutorial_HoareWorked.thy index d4a1e484..834a17b3 100644 --- a/tutorial/Tutorial_HoareWorked.thy +++ b/tutorial/Tutorial_HoareWorked.thy @@ -490,8 +490,8 @@ text \\<^bold>\1. Explicit modifies-clauses (s2n-bignum).\ E text \\<^bold>\2. AutoCorrode's \AutoLocality\ autogen.\ Driven by \<^emph>\record footprints\: declare which fields each operation touches, - and \locality_autoderive\ produces all pairwise commutativity lemmas - automatically. Plain HOL; no SL connectives.\ + and produces all pairwise commutativity and cancellation lemmas + on the fly. Plain HOL; no SL connectives.\ text \\<^bold>\3. Separation logic.\ \<^emph>\What AutoCorrode picks -- see next section...\\ From ff43a9b6a91f57eb4dacb02e4b379208ce63d05b Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:28 +0100 Subject: [PATCH 09/46] AutoCorrode: Match helper certificates by application AutoLocality stopped unfolding a helper as soon as any registration for the same constant existed. A differently specialized application then had neither a matching certificate nor its definition. Explicit fact attributes likewise hid matching certificates from the default locality bundle. Inspect maximal helper applications in the defining equation and use the typed registration selector for each occurrence. Keep unfolding the helper when any occurrence is unmatched. For fully covered helpers, pass the selected core and disjoint certificates to the generated proof through a proof-private fact, independently of their public attributes. Add regressions for a wrapper calling an unregistered specialization and for a wrapper around a custom-attributed helper. Signed-off-by: Hanno Becker --- Autogen/AutoLocality.thy | 194 ++++++++++++++---- .../AutoLocality_Test_Perf.thy | 26 +++ 2 files changed, 185 insertions(+), 35 deletions(-) diff --git a/Autogen/AutoLocality.thy b/Autogen/AutoLocality.thy index 46f9c673..fcaee9fa 100644 --- a/Autogen/AutoLocality.thy +++ b/Autogen/AutoLocality.thy @@ -2990,15 +2990,107 @@ ML\ andalso not (String.isPrefix "case_" (Long_Name.base_name c))) end - \\Previously registered helpers already carry linear locality certificates in the - record's locality-facts bundle. Prefer those certificates to unfolding the helper body: a - helper may contain a large fold or update telescope whose raw definition is much harder to - normalize, and unfolding it can hide the exact registered operation pattern before its - certificate fires.\ - fun locality_body_helpers_to_unfold ctxt rec_name cname = - locality_body_helper_consts ctxt rec_name cname - |> List.filter (fn helper => - null (get_record_locality_entries_for_const rec_name helper ctxt)) + type locality_body_helper_plan = { + unfold: string list, + certificates: thm list + } + + \\Collect maximal applications of the one-level helper constants in a definition. Looking + at the constant name alone is insufficient: a registration for \<^verbatim>\helper A\ cannot justify + suppressing the definition of an occurrence \<^verbatim>\helper B x R\. Descending through the + arguments, rather than through the application spine, records only the complete occurrence and + not each of its partial prefixes.\ + fun locality_body_helper_applications ctxt cname helpers = + let + fun application_eq + ((helper0, head0, args0), (helper1, head1, args1)) = + helper0 = helper1 andalso + Term.aconv + (Term.list_comb (head0, args0), + Term.list_comb (head1, args1)) + fun collect term applications = + let + val (head, args) = Term.strip_comb term + val applications' = + (case head of + Const (helper, _) => + if member (op =) helpers helper + then insert application_eq (helper, head, args) applications + else applications + | _ => applications) + in + case term of + Abs (_, _, body) => collect body applications' + | _ => fold collect args applications' + end + in + fold (collect o Thm.prop_of) + (locality_def_thms_of ctxt cname) [] + end + + \\Prefer a registered helper's linear certificates only when every actual occurrence in + the definition is covered by a typed registration. The selected certificate objects are passed + directly to the generated proof, so this also works when the helper was registered under a + custom theorem attribute and is absent from the record's default locality-facts bundle. + + If any occurrence is uncovered, unfold the helper definition. This is deliberately + all-or-nothing per helper constant: mixing a certificate for one specialization with raw + unfolding for another makes the automatic proof harder to predict and buys no useful + performance advantage.\ + fun locality_body_helper_plan ctxt rec_name cname : + locality_body_helper_plan = + let + val helpers = locality_body_helper_consts ctxt rec_name cname + val applications = + locality_body_helper_applications ctxt cname helpers + fun matching_entries head args = + [Locality_Operation, Locality_Attribute] + |> map_filter (fn kind => + select_locality_entry_kind_with locality_no_count + ctxt rec_name kind head args + |> Option.map #2) + fun entry_certificates (entry : locality_entry) = + #core_thms entry @ #disjoint_thms entry + fun analyse helper = + let + val helper_applications = + applications + |> List.filter (fn (helper', _, _) => helper = helper') + val entries = + helper_applications + |> map (fn (_, head, args) => + matching_entries head args) + in + if not (null helper_applications) + andalso List.all (not o null) entries + then + (NONE, + flat entries + |> maps entry_certificates) + else + (SOME helper, []) + end + val analyses = map analyse helpers + in + { unfold = map_filter fst analyses, + certificates = + maps snd analyses + |> map (Thm.transfer' ctxt) + |> distinct Thm.eq_thm_prop } + end + + val locality_body_helper_certificate_fact = + "autolocality_body_helper_certificates" + + \\Method strings are parsed against a private copy of the declaration context containing + the selected helper certificates as one internal fact. The fact is captured in the method + closure and never installed in the surrounding local theory or its ambient simpset.\ + fun locality_body_helper_method_context ctxt certificates = + if null certificates then ctxt + else + Proof_Context.put_thms false + (locality_body_helper_certificate_fact, + SOME certificates) ctxt \\Datatype case-split rules (\<^verbatim>\T.split\) for every \<^verbatim>\case_T\ combinator appearing in the bodies of the given constants. An operation whose body is a \<^verbatim>\case x of \\ (e.g. @@ -4570,11 +4662,15 @@ ML\ type clash). *) val p_op_str = "(" ^ (Syntax.pretty_term ctxt p_term |> Pretty.pure_string_of) ^ ")" + val helper_plan = + locality_body_helper_plan ctxt rec_name p_name + val helper_certificates = #certificates helper_plan + (* Constants to unfold when discharging: the operation, the constants baked into a partial - application, and the user-defined helpers/operations the body delegates to. *) + application, and helpers whose actual applications have no matching registration. *) val discharge_cnames = (p_name :: baked_cnames - @ locality_body_helpers_to_unfold ctxt rec_name p_name) + @ #unfold helper_plan) |> distinct (op =) fun arglist_with x = @@ -4670,20 +4766,33 @@ ML\ val default_simps = let val const_unfold = discharge_cnames |> map_filter (locality_def_fact_name ctxt) + val helper_facts = + if null helper_certificates then [] + else [locality_body_helper_certificate_fact] val locality_facts = if Option.isSome attribs_opt then [] else [default_named_theorems_for_record rec_name] - val all_simps = ["Let_def"] @ const_unfold @ locality_facts + val all_simps = + ["Let_def"] @ const_unfold @ helper_facts @ locality_facts in String.concatWith " " all_simps end val default_splits = String.concatWith " " (locality_body_case_split_names ctxt discharge_cnames) - fun start_core_proof ctxt cont = ctxt - |> Proof.theorem NONE (after_qed (not is_field) NONE commutativity_thm_name cont) [map (fn t => (t,[])) commutativity_stms] - |> apply_method (SIMPLE_METHOD all_tac) - |> (if with_proof then - apply_txt ctxt ("(auto simp add: " ^ default_simps ^ " split: " ^ default_splits ^ ")?") - else - I) + fun start_core_proof ctxt cont = + let + val method_ctxt = + locality_body_helper_method_context + ctxt helper_certificates + in + ctxt + |> Proof.theorem NONE (after_qed (not is_field) NONE commutativity_thm_name cont) [map (fn t => (t,[])) commutativity_stms] + |> apply_method (SIMPLE_METHOD all_tac) + |> (if with_proof then + apply_txt method_ctxt + ("(auto simp add: " ^ default_simps + ^ " split: " ^ default_splits ^ ")?") + else + I) + end \\The 'local action' lemma is fully automatic. The old method-string discharge is \<^verbatim>\auto intro: .expand simp add: \: extensionality reduces to per-field @@ -4977,16 +5086,24 @@ ML\ <_locality_facts>\: handing the rules to \<^verbatim>\auto\ by name lets the simplifier reuse the ambient indexed simpset, whereas the WIP rewrite's ML-built simpset paid for ambient construction eagerly per-call.\ - (* As on the operation path: unfold the attribute and the user-defined helpers its body - delegates to, so case/let/delegation attribute bodies normalise. *) + val helper_plan = + locality_body_helper_plan ctxt rec_name p_name + val helper_certificates = #certificates helper_plan + + (* As on the operation path: unfold the attribute and helpers whose actual applications have + no matching registration, so case/let/delegation attribute bodies normalise. *) val attr_discharge_cnames = - (p_name :: locality_body_helpers_to_unfold ctxt rec_name p_name) + (p_name :: #unfold helper_plan) |> distinct (op =) val default_simps = let val const_unfold = attr_discharge_cnames |> map_filter (locality_def_fact_name ctxt) + val helper_facts = + if null helper_certificates then [] + else [locality_body_helper_certificate_fact] val locality_facts = if Option.isSome attribs_opt then [] else [default_named_theorems_for_record rec_name] - val all_simps = ["Let_def"] @ const_unfold @ locality_facts + val all_simps = + ["Let_def"] @ const_unfold @ helper_facts @ locality_facts in String.concatWith " " all_simps end @@ -5023,18 +5140,25 @@ ML\ ctxt0 |> Named_Theorems.declare (Binding.make (cancellation_thms_name, \<^here>)) "" - fun start_core_proof ctxt cont = ctxt - |> Proof.theorem NONE - (after_qed (SOME cancellation_thms_name) - cancellation_thm_name cont) - [map (fn t => (t, [])) commutativity_stms] - |> apply_method (SIMPLE_METHOD all_tac) - |> (if with_proof then - apply_txt ctxt - ("(auto simp add: " ^ default_simps - ^ " split: " ^ default_splits ^ ")?") - else - I) + fun start_core_proof ctxt cont = + let + val method_ctxt = + locality_body_helper_method_context + ctxt helper_certificates + in + ctxt + |> Proof.theorem NONE + (after_qed (SOME cancellation_thms_name) + cancellation_thm_name cont) + [map (fn t => (t, [])) commutativity_stms] + |> apply_method (SIMPLE_METHOD all_tac) + |> (if with_proof then + apply_txt method_ctxt + ("(auto simp add: " ^ default_simps + ^ " split: " ^ default_splits ^ ")?") + else + I) + end in start_core_proof ctxt' wrapup end diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Perf.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Perf.thy index 8765c571..7ef610e9 100644 --- a/Autogen/AutoLocality_Tests/AutoLocality_Test_Perf.thy +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Perf.thy @@ -31,21 +31,47 @@ definition pset_d :: \nat \ perf \ perf\ wh definition pbump_c :: \nat \ perf \ perf\ where \pbump_c k R \ update_qc (\old. old + k + qc R) R\ definition pdelegate_c :: \nat \ perf \ perf\ where \pdelegate_c k R \ pbump_c k R\ +\\Only the \True\ specialization is registered. The delegate below calls \False\, so +helper suppression must inspect the actual application and unfold the unmatched helper body.\ +definition pspecial_c :: \bool \ nat \ perf \ perf\ where + \pspecial_c mode k R \ + update_qc (\old. if mode then old + k else old + k + 1) R\ +definition pdelegate_special_c :: \nat \ perf \ perf\ where + \pdelegate_special_c k R \ pspecial_c False k R\ +\\The custom-attributed helper has certificates in the semantic registry but not in the +record's default locality-facts bundle. Its delegate must use those theorem objects directly.\ +definition pcustom_c :: \nat \ perf \ perf\ where + \pcustom_c k R \ update_qc (\old. old + k + qc R) R\ +definition pdelegate_custom_c :: \nat \ perf \ perf\ where + \pdelegate_custom_c k R \ pcustom_c k R\ \\Attribute on \qd\: disjoint from all of pset_a/pset_b/pset_c/pbump_c.\ definition phas_d :: \perf \ bool\ where \phas_d R \ qd R > 0\ +named_theorems perf_custom_locality + locality_lemma for perf: \pset_a\ footprint [qa] . locality_lemma for perf: \pset_b\ footprint [qb] . locality_lemma for perf: \pset_c\ footprint [qc] . locality_lemma for perf: \pset_d\ footprint [qd] . locality_lemma for perf: \pbump_c\ footprint [qc] . locality_lemma for perf: \pdelegate_c\ footprint [qc] . +locality_lemma for perf: \pspecial_c True\ footprint [qc] . +locality_lemma for perf: \pdelegate_special_c\ footprint [qc] . +locality_lemma for perf [perf_custom_locality]: + \pcustom_c\ footprint [qc] . +locality_lemma for perf: \pdelegate_custom_c\ footprint [qc] . locality_lemma for perf: \phas_d\ footprint [qd] . text\Sanity: a deep nest cancels by plain @{term \simp\} as an object-level lemma too.\ lemma \phas_d (pset_a a (pset_b b (pset_c c (pbump_c k (pset_a a2 X))))) = phas_d X\ by simp +lemma \phas_d (pdelegate_special_c k X) = phas_d X\ + by simp + +lemma \phas_d (pdelegate_custom_c k X) = phas_d X\ + by simp + ML\ val ctxt = \<^context> \\Build an n-deep telescope of disjoint operations under phas_d and time its cancellation.\ From 489a53aae3400e389e885062f1cce8882c7614d5 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:28 +0100 Subject: [PATCH 10/46] AutoCorrode: Infer records for explicit locality facts Explicit `locality_autocancellation` and `locality_autocommutativity` facts required callers to repeat the record type even when their registrations identified it uniquely. Query the semantic registry for matching operation and attribute entries and accept the inferred form only when exactly one record remains. Keep the typed syntax as an explicit disambiguator. Missing or ambiguous registrations fail before theorem construction; the existing proof builders and their coverage remain unchanged. Add success, compatibility, and inherited-record ambiguity regressions, document both forms, and remove redundant record arguments from existing unambiguous users. Signed-off-by: Hanno Becker --- Autogen/AutoLocality.thy | 209 ++++++++++++++++-- .../AutoLocality_B0_Base.thy | 11 + .../AutoLocality_C1_Counters.thy | 2 +- .../AutoLocality_Tests/AutoLocality_Test3.thy | 10 +- .../AutoLocality_Test_Boundaries.thy | 9 + .../AutoLocality_Test_Contexts.thy | 4 +- .../AutoLocality_Test_Locale.thy | 4 +- .../AutoLocality_Test_Record_Extension.thy | 35 ++- 8 files changed, 258 insertions(+), 26 deletions(-) diff --git a/Autogen/AutoLocality.thy b/Autogen/AutoLocality.thy index fcaee9fa..48f30def 100644 --- a/Autogen/AutoLocality.thy +++ b/Autogen/AutoLocality.thy @@ -278,6 +278,11 @@ ML\ Locality_Attribute | Locality_Operation + exception Locality_Registry_Ambiguity of string + + fun locality_registry_ambiguity message = + raise Locality_Registry_Ambiguity message + fun locality_entry_kind_name Locality_Attribute = "attribute" | locality_entry_kind_name Locality_Operation = "operation" @@ -1370,7 +1375,10 @@ ML\ (case Exn.capture f () of Exn.Res result => SOME result | Exn.Exn exn => - if Exn.is_interrupt exn then Exn.reraise exn else NONE) + if Exn.is_interrupt exn then Exn.reraise exn + else (case exn of + Locality_Registry_Ambiguity _ => Exn.reraise exn + | _ => NONE)) fun locality_terms_provably_equal_with count ctxt (lhs, rhs) = let @@ -2707,7 +2715,8 @@ ML\ locality_specialize_entry_with count ctxt actual entry) end else - error ("Ambiguous autolocality registrations on " ^ rec_name) + locality_registry_ambiguity + ("Ambiguous autolocality registrations on " ^ rec_name) end fun select_locality_entry_with count ctxt rec_name kind_name head args = @@ -3916,7 +3925,8 @@ ML\ | entry :: _ => if locality_entries_have_same_effect_with count candidates then SOME (locality_specialize_entry_with count ctxt pattern entry) - else error ("Ambiguous autolocality pattern on " ^ rec_name) + else locality_registry_ambiguity + ("Ambiguous autolocality pattern on " ^ rec_name) end fun select_locality_entry_for_pattern_with count @@ -3949,7 +3959,8 @@ ML\ | entry :: _ => if locality_entries_have_same_effect_with count candidates then SOME (locality_specialize_entry_with count ctxt pattern entry) - else error ("Ambiguous autolocality pattern on " ^ rec_name) + else locality_registry_ambiguity + ("Ambiguous autolocality pattern on " ^ rec_name) end fun select_locality_entry_for_pattern_at_idx_with count @@ -3963,6 +3974,153 @@ ML\ (locality_direct_counter ctxt) ctxt rec_name kind_name pattern idx + fun locality_pattern_at_entry_type ctxt pattern + (entry : locality_entry) = + let + val thy = Proof_Context.theory_of ctxt + val target = #pattern entry + val fresh_inc = Term.maxidx_of_term target + 1 + val pattern' = + pattern + |> locality_varify_types_preserving + (locality_assumption_tfrees ctxt) + |> Term.map_types (Logic.incr_tvar fresh_inc) + val type_env = + Sign.typ_match thy + (Term.type_of pattern', Term.type_of target) + Vartab.empty + in + Envir.subst_term_types type_env pattern' + end + + fun locality_explicit_pattern_candidates_with count ctxt + rec_name kind pattern absolute_idx = + let + val _ = locality_count_one count + AutoLocality_Instrumentation.Lookup_Requests + val keys = + (case absolute_idx of + NONE => + locality_pattern_keys_with count ctxt rec_name kind pattern + | SOME idx => + locality_pattern_at_idx_keys_with + count ctxt rec_name kind pattern idx) + val entries = + locality_entries_for_keys_generic + (Context.Proof ctxt) + (LocalityOperationalKeyTable.keys keys) + val _ = locality_count_list count + AutoLocality_Instrumentation.Lookup_Entries_Examined entries + fun specialize entry = + capture_noninterrupt (fn () => + let + val actual = + locality_pattern_at_entry_type ctxt pattern entry + val _ = + if locality_entry_matches_prefix_with count + ctxt actual entry + then () + else raise Pattern.MATCH + in + locality_specialize_entry_with count + ctxt actual entry + end) + val candidates = map_filter specialize entries + val _ = locality_count_list count + AutoLocality_Instrumentation.Lookup_Candidates_Returned + candidates + in + candidates + end + + fun select_locality_entry_for_explicit_pattern_with count ctxt + rec_name kind pattern absolute_idx = + case locality_explicit_pattern_candidates_with count ctxt + rec_name kind pattern absolute_idx of + [] => NONE + | entry :: entries => + if locality_entries_have_same_effect_with count + (entry :: entries) + then SOME entry + else locality_registry_ambiguity + ("Ambiguous autolocality pattern on " ^ rec_name) + + fun locality_commutativity_record_candidates_with count + ctxt patternA patternB = + let + fun has_operation rec_name pattern = + select_locality_entry_for_explicit_pattern_with count + ctxt rec_name Locality_Operation pattern NONE + |> Option.isSome + in + get_registered_records ctxt + |> List.filter (fn rec_name => + has_operation rec_name patternA + andalso has_operation rec_name patternB) + |> sort_strings + end + + fun locality_commutativity_record_candidates ctxt patternA patternB = + locality_commutativity_record_candidates_with + (locality_direct_counter ctxt) ctxt patternA patternB + + fun locality_cancellation_record_candidates_with count + ctxt operation_pattern attribute_pattern + attribute_relative_idx = + let + val attribute_absolute_idx = + length (snd (Term.strip_comb attribute_pattern)) + + attribute_relative_idx + fun has_operation rec_name = + select_locality_entry_for_explicit_pattern_with count + ctxt rec_name Locality_Operation operation_pattern NONE + |> Option.isSome + fun has_attribute rec_name = + select_locality_entry_for_explicit_pattern_with count + ctxt rec_name Locality_Attribute attribute_pattern + (SOME attribute_absolute_idx) + |> Option.isSome + in + get_registered_records ctxt + |> List.filter (fn rec_name => + has_operation rec_name andalso has_attribute rec_name) + |> sort_strings + end + + fun locality_cancellation_record_candidates ctxt + operation_pattern attribute_pattern + attribute_relative_idx = + locality_cancellation_record_candidates_with + (locality_direct_counter ctxt) ctxt + operation_pattern attribute_pattern + attribute_relative_idx + + fun locality_require_unique_record attribute_name candidates = + case candidates of + [rec_name] => rec_name + | [] => + error (attribute_name ^ ": cannot infer a record type from the " + ^ "supplied registrations; use the explicit (record_type) form") + | _ => + error (attribute_name ^ ": record type is ambiguous among " + ^ space_implode ", " (map quote candidates) + ^ "; use the explicit (record_type) form") + + fun locality_infer_commutativity_record + ctxt patternA patternB = + locality_commutativity_record_candidates ctxt patternA patternB + |> locality_require_unique_record + "locality_autocommutativity" + + fun locality_infer_cancellation_record + ctxt operation_pattern attribute_pattern + attribute_relative_idx = + locality_cancellation_record_candidates ctxt + operation_pattern attribute_pattern + attribute_relative_idx + |> locality_require_unique_record + "locality_autocancellation" + \\Auto-derive the pairwise commutativity theorem for two registered operations on a record: \<^verbatim>\opA argsA (opB argsB R) = opB argsB (opA argsA R)\, with the non-record arguments held as fixed fresh frees and the record threaded through the registered argument position of each. @@ -4104,12 +4262,14 @@ ML\ Exn.Res result => result | Exn.Exn exn => if Exn.is_interrupt exn then Exn.reraise exn - else + else (case exn of + Locality_Registry_Ambiguity _ => Exn.reraise exn + | _ => (locality_pretty_trace ctxt 1 (fn () => Pretty.text "locality cancellation declined after exception:" @ [Pretty.brk 1, Pretty.str (Runtime.exn_message exn)] |> Pretty.block); - NONE)) + NONE))) fun locality_cancellation_for_entry rec_name attribute ctxt ctm = locality_cancellation_for_entry_with @@ -5475,14 +5635,16 @@ attribute_setup locality_no_cancel = text\On-demand pairwise operation commutativity. The default-on cancellation simprocs only fire when an \<^emph>\attribute\ heads the telescope; a bare \<^verbatim>\opA (opB R)\ is not rewritten. Where a proof needs the -two operations to commute, \<^verbatim>\[[locality_autocommutativity (rec) A B]]\ derives that theorem from the +two operations to commute, \<^verbatim>\[[locality_autocommutativity A B]]\ derives that theorem from the footprint data and \<^emph>\returns it as a fact\ (generalized to schematics, so it applies as a rewrite or rule) - nothing is registered permanently and the ambient simpset is not touched. It is used in a -\<^emph>\fact position\: name it with \<^verbatim>\lemmas c = [[locality_autocommutativity (rec) A B]]\, discharge a bare -op-over-op goal with \<^verbatim>\by (rule [[locality_autocommutativity (rec) A B]])\, or feed it to a tactic -with \<^verbatim>\by (simp add: [[locality_autocommutativity (rec) A B]])\. It is sound: operations with disjoint +\<^emph>\fact position\: name it with \<^verbatim>\lemmas c = [[locality_autocommutativity A B]]\, discharge a bare +op-over-op goal with \<^verbatim>\by (rule [[locality_autocommutativity A B]])\, or feed it to a tactic +with \<^verbatim>\by (simp add: [[locality_autocommutativity A B]])\. It is sound: operations with disjoint footprints commute and yield a theorem; a footprint-sharing pair genuinely does not commute and -raises an error rather than fabricating a false theorem. The record type is given in parentheses. +raises an error rather than fabricating a false theorem. The record type is normally inferred by +intersecting the records carrying matching registrations for both operations. The existing +\<^verbatim>\(rec)\ prefix remains available when polymorphic constants make that intersection ambiguous. Because the attribute ignores the theorem it is applied to and synthesises a fresh one, it works from the empty \<^verbatim>\[[\]]\ fact form (which seeds the attribute chain with \<^verbatim>\Drule.dummy_thm\): the @@ -5498,13 +5660,20 @@ definition - and misspelled operands are rejected at parse time. \<^ML>\Ar the fully-qualified constant name the footprint database is keyed under, so it is passed straight to \<^verbatim>\locality_prove_commutativity\.\ attribute_setup locality_autocommutativity = - \(Scan.lift (Args.parens Parse.typ) -- Args.const {proper = false, strict = false} + \(Scan.option (Scan.lift (Args.parens Parse.typ)) + -- Args.const {proper = false, strict = false} -- Args.const {proper = false, strict = false}) >> (fn ((rc, a), b) => Thm.rule_attribute [] (fn context => fn _ (* incoming (dummy) thm, discarded *) => let val ctxt = Context.proof_of context val patternA = Syntax.read_term ctxt a val patternB = Syntax.read_term ctxt b + val rc = + (case rc of + SOME rec_name => rec_name + | NONE => + locality_infer_commutativity_record + ctxt patternA patternB) in case locality_prove_commutativity ctxt rc patternA patternB of SOME thm => Thm.forall_intr_frees thm |> Thm.forall_elim_vars 0 @@ -5515,14 +5684,17 @@ attribute_setup locality_autocommutativity = text\For restricted simplifier calls such as \<^verbatim>\simp only\, the default cancellation simprocs are intentionally absent. The fact attribute -\<^verbatim>\[[locality_autocancellation (rec) operation attribute index]]\ derives exactly the requested +\<^verbatim>\[[locality_autocancellation operation attribute index]]\ derives exactly the requested operation/attribute projection equation on demand. The index is relative to the remaining attribute arguments after any prefix already supplied by the proof context. In particular, implicit locale parameters do not count. The index distinguishes registrations of one attribute at multiple record slots. As with \<^verbatim>\locality_autocommutativity\, no theorem is -registered permanently.\ +registered permanently. The record is normally inferred by intersecting the operation and indexed +attribute registrations. The existing \<^verbatim>\(rec)\ prefix disambiguates polymorphic constants +registered for multiple records.\ attribute_setup locality_autocancellation = - \(Scan.lift (Args.parens Parse.typ) -- Args.const {proper = false, strict = false} + \(Scan.option (Scan.lift (Args.parens Parse.typ)) + -- Args.const {proper = false, strict = false} -- Args.const {proper = false, strict = false} -- Scan.lift Parse.nat) >> (fn (((rc, operation), attribute), attribute_idx) => Thm.rule_attribute [] (fn context => fn _ => @@ -5530,6 +5702,13 @@ attribute_setup locality_autocancellation = val ctxt = Context.proof_of context val operation_pattern = Syntax.read_term ctxt operation val attribute_pattern = Syntax.read_term ctxt attribute + val rc = + (case rc of + SOME rec_name => rec_name + | NONE => + locality_infer_cancellation_record ctxt + operation_pattern attribute_pattern + attribute_idx) in case locality_prove_cancellation_fact ctxt rc operation_pattern attribute_pattern attribute_idx of diff --git a/Autogen/AutoLocality_Tests/AutoLocality_B0_Base.thy b/Autogen/AutoLocality_Tests/AutoLocality_B0_Base.thy index 7ace13f0..17168503 100644 --- a/Autogen/AutoLocality_Tests/AutoLocality_B0_Base.thy +++ b/Autogen/AutoLocality_Tests/AutoLocality_B0_Base.thy @@ -151,12 +151,23 @@ lemma b0_base_on_demand_cancellation: by (simp only: [[locality_autocancellation (b0_state) b0_set_c b0_has_a 0]]) +lemma b0_base_inferred_on_demand_cancellation: + shows \b0_has_a (b0_set_c n R) = b0_has_a R\ + by (simp only: + [[locality_autocancellation b0_set_c b0_has_a 0]]) + lemma b0_base_on_demand_commutativity: shows \b0_set_b m (b0_set_c n R) = b0_set_c n (b0_set_b m R)\ by (rule [[locality_autocommutativity (b0_state) b0_set_b b0_set_c]]) +lemma b0_base_inferred_on_demand_commutativity: + shows \b0_set_b m (b0_set_c n R) = + b0_set_c n (b0_set_b m R)\ + by (rule + [[locality_autocommutativity b0_set_b b0_set_c]]) + text\Repeated record initialization is part of the public compatibility surface and must remain idempotent.\ diff --git a/Autogen/AutoLocality_Tests/AutoLocality_C1_Counters.thy b/Autogen/AutoLocality_Tests/AutoLocality_C1_Counters.thy index 1c9114ba..9dcf9f4c 100644 --- a/Autogen/AutoLocality_Tests/AutoLocality_C1_Counters.thy +++ b/Autogen/AutoLocality_Tests/AutoLocality_C1_Counters.thy @@ -637,7 +637,7 @@ lemma c1_counter_explicit_fact_ignores_ambient_opt_out: shows \c1_counter_attr_a (c1_counter_front_cd R) = c1_counter_attr_a R\ by (rule [[locality_autocancellation - (c1_counter_state) c1_counter_front_cd c1_counter_attr_a 0]]) + c1_counter_front_cd c1_counter_attr_a 0]]) context notes [[locality_cancel]] diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test3.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test3.thy index c504fb7c..24dbe539 100644 --- a/Autogen/AutoLocality_Tests/AutoLocality_Test3.thy +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test3.thy @@ -94,7 +94,7 @@ lemma \has_a (update_fb g (update_fc hf X)) = has_a X\ by simp lemma \read_b (set_c c (opaque_a h (opaque_b b X))) = read_b (opaque_b b X)\ by simp lemma \has_a (opaque_b k R) = has_a R\ - by (simp only: [[locality_autocancellation (three) opaque_b has_a 0]]) + by (simp only: [[locality_autocancellation opaque_b has_a 0]]) text\The cancellation also works through \<^verbatim>\simp add: _locality_facts\, the bundle form that downstream proofs use: the simprocs ride along in the ambient simpset.\ @@ -141,7 +141,7 @@ ML\ | NONE => error "opaque_a/set_c should have a derived theorem" \ -text\The same derivation is reachable from proof text via the \<^verbatim>\[[locality_autocommutativity (rec) A B]]\ +text\The same derivation is reachable from proof text via the \<^verbatim>\[[locality_autocommutativity A B]]\ attribute, which \<^emph>\returns\ the (generalized) commutativity theorem as a fact rather than mutating the simpset. A bare operation-over-operation goal - which the default-on cancellation simprocs do \<^emph>\not\ rewrite, since no attribute heads it - then closes by using that fact directly. We exercise all @@ -149,17 +149,17 @@ three fact-position idioms: naming it with \<^theory_text>\lemmas\, \<^theory_text>\simp add:\.\ text\Name the produced theorem, then discharge with it.\ -lemmas opaque_a_set_c_commute = [[locality_autocommutativity (three) opaque_a set_c]] +lemmas opaque_a_set_c_commute = [[locality_autocommutativity opaque_a set_c]] lemma \opaque_a a (set_c c R) = set_c c (opaque_a a R)\ by (rule opaque_a_set_c_commute) text\Or use the anonymous \<^verbatim>\[[\]]\ fact inline, resolving against the goal.\ lemma \opaque_a a (set_c c R) = set_c c (opaque_a a R)\ - by (rule [[locality_autocommutativity (three) opaque_a set_c]]) + by (rule [[locality_autocommutativity opaque_a set_c]]) text\Or hand it to \<^verbatim>\simp add:\ as a rewrite (the schematic generalization is what makes this work).\ lemma \set_c c (opaque_b b R) = opaque_b b (set_c c R)\ - by (simp add: [[locality_autocommutativity (three) set_c opaque_b]]) + by (simp add: [[locality_autocommutativity set_c opaque_b]]) text\Without the attribute the same bare goal is \<^emph>\not\ closed by a plain \<^verbatim>\simp\ (the cancellation simprocs only fire under an attribute head), so unfolding is required - confirming the attribute is diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Boundaries.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Boundaries.thy index c9520bd8..d2ba1399 100644 --- a/Autogen/AutoLocality_Tests/AutoLocality_Test_Boundaries.thy +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Boundaries.thy @@ -22,6 +22,10 @@ definition boundary_attr :: \boundary_rec \ bool\ where definition boundary_rank_attr :: \'a \ boundary_rec \ bool\ where \boundary_rank_attr x R \ boundary_attr R\ +definition boundary_rank_attr2 :: + \nat \ boundary_rec \ nat \ bool\ where + \boundary_rank_attr2 x R y \ boundary_attr R\ + definition manual_flip :: \boundary_rec \ boundary_rec\ where \manual_flip R \ update_ba Suc R\ @@ -851,6 +855,11 @@ ML\ (case ambiguous_inference_result of Exn.Exn (Locality_Registry_Ambiguity _) => true | _ => false)), + ("generic exception capture preserves registry ambiguity", + fn () => AutoLocality_Assert.check "captured registry ambiguity" + (case ambiguity_capture_result of + Exn.Exn (Locality_Registry_Ambiguity _) => true + | _ => false)), ("generic exception capture preserves registry ambiguity", fn () => AutoLocality_Assert.check "captured registry ambiguity" (case ambiguity_capture_result of diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Contexts.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Contexts.thy index 2369cda7..73263717 100644 --- a/Autogen/AutoLocality_Tests/AutoLocality_Test_Contexts.thy +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Contexts.thy @@ -282,10 +282,10 @@ lemma \pair_attr (set_c n L) (set_c m R) = pair_attr L R\ by simp lemma \pair_attr (set_c n L) R = pair_attr L R\ - by (simp only: [[locality_autocancellation (ctx) set_c pair_attr 0]]) + by (simp only: [[locality_autocancellation set_c pair_attr 0]]) lemma \pair_attr L (set_a n R) = pair_attr L R\ - by (simp only: [[locality_autocancellation (ctx) set_a pair_attr 1]]) + by (simp only: [[locality_autocancellation set_a pair_attr 1]]) ML\ val ctxt = \<^context> diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Locale.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Locale.thy index 9e9d95c3..53f4b041 100644 --- a/Autogen/AutoLocality_Tests/AutoLocality_Test_Locale.thy +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Locale.thy @@ -140,10 +140,10 @@ text\A footprint-disjoint operation under the parameter-using attribute ca lemma \bigval (setc c X) = bigval X\ by simp lemma explicit_cancellation_uses_relative_index: shows \bigval (setc c X) = bigval X\ - by (rule [[locality_autocancellation (loc) setc bigval 0]]) + by (rule [[locality_autocancellation setc bigval 0]]) lemma explicit_cancellation_uses_nonzero_relative_index: shows \bigval_at n (setc c X) = bigval_at n X\ - by (rule [[locality_autocancellation (loc) setc bigval_at 1]]) + by (rule [[locality_autocancellation setc bigval_at 1]]) lemma \bigval (setc c (bumpval X)) = bigval (bumpval X)\ by simp \\The parameter-using operation's own disjointness lemma holds.\ lemma \ob (bumpval X) = ob X\ by simp diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Record_Extension.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Record_Extension.thy index ef860c26..1721787a 100644 --- a/Autogen/AutoLocality_Tests/AutoLocality_Test_Record_Extension.thy +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Record_Extension.thy @@ -16,6 +16,7 @@ record standard_base = record standard_ext = standard_base + std_c :: nat +locality_init for standard_base locality_init for standard_ext definition std_bump_a :: \standard_ext \ standard_ext\ where @@ -56,6 +57,18 @@ ML\ val expected_updates = map (suffix Record.updateN) expected_fields val registered_fields = entries |> filter #field |> map #const_name + val bump_a_pattern = Syntax.read_term ctxt "std_a_update" + val bump_b_pattern = Syntax.read_term ctxt "std_b_update" + val has_b_pattern = Syntax.read_term ctxt "std_b" + val cancellation_candidates = + locality_cancellation_record_candidates ctxt + bump_a_pattern has_b_pattern 0 + val commutativity_candidates = + locality_commutativity_record_candidates ctxt + bump_a_pattern bump_b_pattern + val expected_ambiguous_records = + ["AutoLocality_Test_Record_Extension.standard_base", + "AutoLocality_Test_Record_Extension.standard_ext"] val _ = AutoLocality_Assert.run_suite "Record-extension/metadata" [ ("inherited and new selectors are registered", fn () => AutoLocality_Assert.check "all standard selectors" @@ -67,7 +80,27 @@ ML\ fn () => AutoLocality_Assert.check "custom operation" (case one "AutoLocality_Test_Record_Extension.std_bump_a" of [entry] => not (#field entry) - | _ => false)) ] + | _ => false)), + ("cancellation inference sees both record registrations", + fn () => AutoLocality_Assert.check + "ambiguous cancellation records" + (cancellation_candidates = expected_ambiguous_records)), + ("commutativity inference sees both record registrations", + fn () => AutoLocality_Assert.check + "ambiguous commutativity records" + (commutativity_candidates = expected_ambiguous_records)), + ("ambiguous cancellation requires an explicit record", + fn () => AutoLocality_Assert.assert_raises + "ambiguous cancellation inference" + (fn () => + locality_infer_cancellation_record ctxt + bump_a_pattern has_b_pattern 0)), + ("ambiguous commutativity requires an explicit record", + fn () => AutoLocality_Assert.assert_raises + "ambiguous commutativity inference" + (fn () => + locality_infer_commutativity_record ctxt + bump_a_pattern bump_b_pattern)) ] \ (*<*) From 96b223539194dfad973115100091a6dd25112077 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:28 +0100 Subject: [PATCH 11/46] AutoCorrode: Add fine-grained PIDE timing The existing jEdit timing panel reports whole command totals. It cannot show which internal operations of a custom tactic consume time or retain the cost of attempts that return no result. Introduce one profile around a tactic invocation. Nested `time` wrappers measure named operations inside it. The profile combines samples and publishes one compact report when the invocation finishes. PIDE traffic is bounded by invocations and signal names, not attempts. Keep measurement separate from destinations. Context-local sink factories can publish to PIDE, tracing output, or another consumer. Skip the clock entirely when no sink is active. Use a synchronized accumulator on an immutable context stack. Pull one ordinary lazy-sequence result, preserve it, and write nested samples only to the innermost profile. Schema version 2 carries invocation identity, outcome, totals, extrema, and fixed histogram buckets. The decoder continues to accept version 1. Add a standalone Isabelle component, ML API and tests, Scala decoder and scope model, and a jEdit dockable with call and aggregate views for command, proof, theory, and global scope. Signed-off-by: Hanno Becker --- Fine_Grained_Timing/.gitignore | 1 + Fine_Grained_Timing/Fine_Grained_Timing.thy | 10 + Fine_Grained_Timing/Makefile | 102 +++ Fine_Grained_Timing/ROOT | 3 + Fine_Grained_Timing/ROOTS | 1 + Fine_Grained_Timing/etc/options | 9 + Fine_Grained_Timing/etc/settings | 3 + Fine_Grained_Timing/resources/dockables.xml | 8 + Fine_Grained_Timing/resources/plugin.props | 17 + .../src/FineGrainedTiming.scala | 197 ++++++ .../src/FineGrainedTimingDockable.scala | 432 ++++++++++++ .../src/FineGrainedTimingPlugin.scala | 6 + .../src/FineGrainedTimingScope.scala | 62 ++ .../test/FineGrainedTimingScopeTest.scala | 47 ++ .../test/FineGrainedTimingTest.scala | 142 ++++ .../test/Fine_Grained_Timing_Test.thy | 184 ++++++ Fine_Grained_Timing/test/ROOT | 3 + Fine_Grained_Timing/time.ML | 625 ++++++++++++++++++ Makefile | 21 +- ROOT | 1 + ROOTS | 1 + 21 files changed, 1867 insertions(+), 8 deletions(-) create mode 100644 Fine_Grained_Timing/.gitignore create mode 100644 Fine_Grained_Timing/Fine_Grained_Timing.thy create mode 100644 Fine_Grained_Timing/Makefile create mode 100644 Fine_Grained_Timing/ROOT create mode 100644 Fine_Grained_Timing/ROOTS create mode 100644 Fine_Grained_Timing/etc/options create mode 100644 Fine_Grained_Timing/etc/settings create mode 100644 Fine_Grained_Timing/resources/dockables.xml create mode 100644 Fine_Grained_Timing/resources/plugin.props create mode 100644 Fine_Grained_Timing/src/FineGrainedTiming.scala create mode 100644 Fine_Grained_Timing/src/FineGrainedTimingDockable.scala create mode 100644 Fine_Grained_Timing/src/FineGrainedTimingPlugin.scala create mode 100644 Fine_Grained_Timing/src/FineGrainedTimingScope.scala create mode 100644 Fine_Grained_Timing/test/FineGrainedTimingScopeTest.scala create mode 100644 Fine_Grained_Timing/test/FineGrainedTimingTest.scala create mode 100644 Fine_Grained_Timing/test/Fine_Grained_Timing_Test.thy create mode 100644 Fine_Grained_Timing/test/ROOT create mode 100644 Fine_Grained_Timing/time.ML diff --git a/Fine_Grained_Timing/.gitignore b/Fine_Grained_Timing/.gitignore new file mode 100644 index 00000000..567609b1 --- /dev/null +++ b/Fine_Grained_Timing/.gitignore @@ -0,0 +1 @@ +build/ diff --git a/Fine_Grained_Timing/Fine_Grained_Timing.thy b/Fine_Grained_Timing/Fine_Grained_Timing.thy new file mode 100644 index 00000000..4b60c9be --- /dev/null +++ b/Fine_Grained_Timing/Fine_Grained_Timing.thy @@ -0,0 +1,10 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +theory Fine_Grained_Timing + imports Pure +begin + +ML_file "time.ML" + +end diff --git a/Fine_Grained_Timing/Makefile b/Fine_Grained_Timing/Makefile new file mode 100644 index 00000000..3d4489bd --- /dev/null +++ b/Fine_Grained_Timing/Makefile @@ -0,0 +1,102 @@ +# Makefile for the Fine-Grained Timing component and jEdit plugin + +ifndef V +.SILENT: +endif + +COMPONENT_DIR := $(shell pwd) +ISABELLE_HOME ?= /Applications/Isabelle2025-2.app +ISABELLE ?= $(if $(wildcard $(ISABELLE_HOME)/bin/isabelle),$(ISABELLE_HOME)/bin/isabelle,$(ISABELLE_HOME)/isabelle) +JEDIT_DIR := $(shell ls -d $(ISABELLE_HOME)/contrib/jedit-* 2>/dev/null | head -1) +JEDIT_JAR ?= $(JEDIT_DIR)/jedit5.7.0-patched/jedit.jar +SCALA_HOME ?= $(ISABELLE_HOME)/contrib/scala-3.3.4 +SCALAC ?= $(SCALA_HOME)/bin/scalac +SCALA_FLAGS ?= -deprecation -feature -unchecked -Werror -Wunused:imports,privates,locals,params -Xlint:all -Wvalue-discard -Wnonunit-statement +SCALA ?= $(SCALA_HOME)/bin/scala +ISABELLE_JAR ?= $(ISABELLE_HOME)/lib/classes/isabelle.jar +JAVA_HOME ?= $(shell $(ISABELLE) getenv -b JAVA_HOME 2>/dev/null) +JAR ?= $(if $(JAVA_HOME),$(JAVA_HOME)/bin/jar,jar) +JAVA_ENV = $(if $(JAVA_HOME),JAVA_HOME="$(JAVA_HOME)" PATH="$(JAVA_HOME)/bin:$$PATH",) + +BUILD_DIR ?= $(COMPONENT_DIR)/build +CLASSES_DIR ?= $(BUILD_DIR)/classes +TEST_CLASSES_DIR ?= $(BUILD_DIR)/test-classes +JAR_FILE ?= $(BUILD_DIR)/fine_grained_timing.jar +INSTALL_DIR ?= $(HOME)/.isabelle/Isabelle2025-2/jedit/jars + +SCALA_SOURCES := $(wildcard src/*.scala) +RESOURCE_FILES := $(wildcard resources/*) +TEST_SOURCES := $(wildcard test/*.scala) +TEST_CLASSPATH = $(CLASSES_DIR):$(TEST_CLASSES_DIR):$(JEDIT_JAR):$(ISABELLE_JAR) + +.PHONY: all build test session-test register install clean uninstall + +all: build + +build: $(JAR_FILE) + echo "Fine-Grained Timing plugin built: $(JAR_FILE)" + +test: build $(TEST_CLASSES_DIR)/.compiled + echo "Running timing model tests..." + $(ISABELLE) scala \ + -classpath "$(CLASSES_DIR):$(TEST_CLASSES_DIR)" \ + FineGrainedTimingTest + echo "Running timing scope tests..." + $(JAVA_ENV) $(SCALA) \ + -classpath "$(TEST_CLASSPATH)" \ + FineGrainedTimingScopeTest + echo "Fine-Grained Timing Scala tests passed." + +session-test: + $(ISABELLE) build -d . Fine_Grained_Timing_Test + +register: + $(ISABELLE) components -u "$(COMPONENT_DIR)" + +install: register $(JAR_FILE) + echo "Installing Fine-Grained Timing plugin to $(INSTALL_DIR)..." + mkdir -p $(INSTALL_DIR) + @set -eu; \ + tmp_jar="$(INSTALL_DIR)/.fine_grained_timing.jar.tmp.$$"; \ + cp "$(JAR_FILE)" "$$tmp_jar"; \ + mv -f "$$tmp_jar" "$(INSTALL_DIR)/fine_grained_timing.jar" + echo "Restart Isabelle/jEdit to load the updated plugin and options." + +$(JAR_FILE): $(CLASSES_DIR)/.compiled $(CLASSES_DIR)/.resources + echo "Creating Fine-Grained Timing plugin JAR..." + $(JAVA_ENV) cd $(CLASSES_DIR) && $(JAR) cf $(JAR_FILE) . + +$(CLASSES_DIR)/.compiled: $(SCALA_SOURCES) | $(CLASSES_DIR) + echo "Compiling Fine-Grained Timing Scala sources..." + $(JAVA_ENV) $(SCALAC) \ + $(SCALA_FLAGS) \ + -classpath "$(JEDIT_JAR):$(ISABELLE_JAR)" \ + -d $(CLASSES_DIR) \ + $(SCALA_SOURCES) + touch $@ + +$(CLASSES_DIR)/.resources: $(RESOURCE_FILES) | $(CLASSES_DIR) + echo "Copying Fine-Grained Timing resources..." + cp -r resources/* $(CLASSES_DIR)/ + touch $@ + +$(TEST_CLASSES_DIR)/.compiled: $(TEST_SOURCES) $(CLASSES_DIR)/.compiled | $(TEST_CLASSES_DIR) + echo "Compiling Fine-Grained Timing tests..." + $(JAVA_ENV) $(SCALAC) \ + $(SCALA_FLAGS) \ + -classpath "$(CLASSES_DIR):$(JEDIT_JAR):$(ISABELLE_JAR)" \ + -d $(TEST_CLASSES_DIR) \ + $(TEST_SOURCES) + touch $@ + +$(CLASSES_DIR): + mkdir -p $(CLASSES_DIR) + +$(TEST_CLASSES_DIR): + mkdir -p $(TEST_CLASSES_DIR) + +clean: + rm -rf $(BUILD_DIR) + +uninstall: + rm -f $(INSTALL_DIR)/fine_grained_timing.jar diff --git a/Fine_Grained_Timing/ROOT b/Fine_Grained_Timing/ROOT new file mode 100644 index 00000000..31b22744 --- /dev/null +++ b/Fine_Grained_Timing/ROOT @@ -0,0 +1,3 @@ +session Fine_Grained_Timing = Pure + + theories + Fine_Grained_Timing diff --git a/Fine_Grained_Timing/ROOTS b/Fine_Grained_Timing/ROOTS new file mode 100644 index 00000000..9daeafb9 --- /dev/null +++ b/Fine_Grained_Timing/ROOTS @@ -0,0 +1 @@ +test diff --git a/Fine_Grained_Timing/etc/options b/Fine_Grained_Timing/etc/options new file mode 100644 index 00000000..cfa3f107 --- /dev/null +++ b/Fine_Grained_Timing/etc/options @@ -0,0 +1,9 @@ +(* :mode=isabelle-options: *) + +section "Fine-grained timing" + +public option fine_grained_timing : bool = false for content + -- "emit bounded fine-grained timing reports for tactic invocations" + +public option fine_grained_timing_output : bool = false for content + -- "print each fine-grained timing sample as prover output" diff --git a/Fine_Grained_Timing/etc/settings b/Fine_Grained_Timing/etc/settings new file mode 100644 index 00000000..9e2c14a6 --- /dev/null +++ b/Fine_Grained_Timing/etc/settings @@ -0,0 +1,3 @@ +# -*- shell-script -*- :mode=shellscript: + +FINE_GRAINED_TIMING_HOME="$COMPONENT" diff --git a/Fine_Grained_Timing/resources/dockables.xml b/Fine_Grained_Timing/resources/dockables.xml new file mode 100644 index 00000000..23510f58 --- /dev/null +++ b/Fine_Grained_Timing/resources/dockables.xml @@ -0,0 +1,8 @@ + + + + + + new FineGrainedTimingDockable(view, position); + + diff --git a/Fine_Grained_Timing/resources/plugin.props b/Fine_Grained_Timing/resources/plugin.props new file mode 100644 index 00000000..f7c5fb46 --- /dev/null +++ b/Fine_Grained_Timing/resources/plugin.props @@ -0,0 +1,17 @@ +# Fine-Grained Timing Plugin Properties + +plugin.FineGrainedTimingPlugin.name=Fine-Grained Timing +plugin.FineGrainedTimingPlugin.author=Amazon Web Services +plugin.FineGrainedTimingPlugin.version=1.0 +plugin.FineGrainedTimingPlugin.description=Fine-grained tactic timing for Isabelle/jEdit +plugin.FineGrainedTimingPlugin.activate=defer +plugin.FineGrainedTimingPlugin.usePluginHome=false + +plugin.FineGrainedTimingPlugin.depend.0=jdk 21 +plugin.FineGrainedTimingPlugin.depend.1=jedit 05.06.00.00 + +plugin.FineGrainedTimingPlugin.menu.label=Fine-Grained Timing +plugin.FineGrainedTimingPlugin.menu=fine-grained-timing-dockable + +fine-grained-timing-dockable.label=Fine-Grained Timing +fine-grained-timing-dockable.title=Fine-Grained Timing diff --git a/Fine_Grained_Timing/src/FineGrainedTiming.scala b/Fine_Grained_Timing/src/FineGrainedTiming.scala new file mode 100644 index 00000000..25abbce0 --- /dev/null +++ b/Fine_Grained_Timing/src/FineGrainedTiming.scala @@ -0,0 +1,197 @@ +/* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT */ + +import isabelle.{Markup, Properties, Value, XML, YXML} + +object FineGrainedTiming { + val ReportMarkup = "fine_grained_timing" + val EntryMarkup = "fine_grained_timing_entry" + val BucketMarkup = "fine_grained_timing_bucket" + val SchemaVersion = 2 + val LegacySchemaVersion = 1 + + final case class Timing(elapsedMicros: Long, cpuMicros: Long, gcMicros: Long) { + def +(other: Timing): Timing = + Timing( + elapsedMicros + other.elapsedMicros, + cpuMicros + other.cpuMicros, + gcMicros + other.gcMicros + ) + } + + final case class Aggregate( + count: Long, + timing: Timing, + minElapsedMicros: Long, + maxElapsedMicros: Long, + histogram: Map[Int, Long] + ) { + def +(other: Aggregate): Aggregate = { + val mergedHistogram = + (histogram.keySet ++ other.histogram.keySet).iterator.map { bucket => + bucket -> (histogram.getOrElse(bucket, 0L) + other.histogram.getOrElse(bucket, 0L)) + }.toMap + Aggregate( + count = count + other.count, + timing = timing + other.timing, + minElapsedMicros = math.min(minElapsedMicros, other.minElapsedMicros), + maxElapsedMicros = math.max(maxElapsedMicros, other.maxElapsedMicros), + histogram = mergedHistogram + ) + } + + def averageElapsedMicros: Double = + if (count == 0L) 0.0 else timing.elapsedMicros.toDouble / count.toDouble + + def percentileElapsedMicros(fraction: Double): Long = { + if (count == 0L || histogram.isEmpty) 0L + else { + val bounded = math.max(0.0, math.min(1.0, fraction)) + val target = math.max(1L, math.ceil(bounded * count.toDouble).toLong) + var accumulated = 0L + val bucket = histogram.toSeq.sortBy(_._1).collectFirst { + case (index, bucketCount) if { + accumulated += bucketCount + accumulated >= target + } => index + }.getOrElse(histogram.keys.max) + bucketUpperBoundMicros(bucket) + } + } + } + + final case class Sample(name: String, success: Boolean, aggregate: Aggregate) + + final case class Invocation( + id: Long, + method: String, + success: Boolean, + timing: Option[Timing], + samples: Vector[Sample] + ) + + final case class SampleKey(name: String, success: Boolean) + + def aggregate(invocations: Iterable[Invocation]): Map[SampleKey, Aggregate] = + invocations.iterator + .flatMap(_.samples) + .foldLeft(Map.empty[SampleKey, Aggregate]) { (result, sample) => + val key = SampleKey(sample.name, sample.success) + result.updatedWith(key) { + case Some(existing) => Some(existing + sample.aggregate) + case None => Some(sample.aggregate) + } + } + + def decode(tree: XML.Tree): Option[Invocation] = + tree match { + case XML.Elem(Markup(ReportMarkup, properties), body) => + for { + version <- intProperty(properties, "version") + if version == LegacySchemaVersion || version == SchemaVersion + invocation <- longProperty(properties, "invocation") + method <- Properties.get(properties, "method") + success <- booleanProperty(properties, "success") + timing <- decodeInvocationTiming(version, properties) + samples <- decodeSamples(normalizeBody(body)) + } yield Invocation( + id = invocation, + method = method, + success = success, + timing = timing, + samples = samples + ) + case _ => None + } + + private def decodeInvocationTiming( + version: Int, + properties: Properties.T + ): Option[Option[Timing]] = + if (version == SchemaVersion) Some(None) + else { + for { + elapsed <- longProperty(properties, "elapsed_us") + cpu <- longProperty(properties, "cpu_us") + gc <- longProperty(properties, "gc_us") + } yield Some(Timing(elapsed, cpu, gc)) + } + + private def normalizeBody(body: XML.Body): XML.Body = + body match { + case List(XML.Text(text)) if YXML.detect(text) => + try YXML.parse_body(YXML.Source(text)) + catch { case _: XML.Error => body } + case _ => body + } + + private def decodeSamples(body: XML.Body): Option[Vector[Sample]] = { + val decoded = body.map(decodeSample) + if (decoded.forall(_.isDefined)) Some(decoded.flatten.toVector) + else None + } + + private def decodeSample(tree: XML.Tree): Option[Sample] = + tree match { + case XML.Elem(Markup(EntryMarkup, properties), body) => + for { + name <- Properties.get(properties, "name") + success <- booleanProperty(properties, "success") + count <- longProperty(properties, "count") + if count > 0L + elapsed <- longProperty(properties, "elapsed_us") + cpu <- longProperty(properties, "cpu_us") + gc <- longProperty(properties, "gc_us") + minimum <- longProperty(properties, "min_elapsed_us") + maximum <- longProperty(properties, "max_elapsed_us") + histogram <- decodeHistogram(body) + if histogram.values.sum == count + } yield Sample( + name = name, + success = success, + aggregate = Aggregate( + count = count, + timing = Timing(elapsed, cpu, gc), + minElapsedMicros = minimum, + maxElapsedMicros = maximum, + histogram = histogram + ) + ) + case _ => None + } + + private def decodeHistogram(body: XML.Body): Option[Map[Int, Long]] = { + val decoded = body.map { + case XML.Elem(Markup(BucketMarkup, properties), Nil) => + for { + bucket <- intProperty(properties, "bucket") + if bucket >= 0 + count <- longProperty(properties, "count") + if count > 0L + } yield bucket -> count + case _ => None + } + if (!decoded.forall(_.isDefined)) None + else { + val entries = decoded.flatten + if (entries.map(_._1).distinct.length != entries.length) None + else Some(entries.toMap) + } + } + + private def intProperty(properties: Properties.T, name: String): Option[Int] = + Properties.get(properties, name).flatMap(Value.Int.unapply) + + private def longProperty(properties: Properties.T, name: String): Option[Long] = + Properties.get(properties, name).flatMap(Value.Long.unapply) + + private def booleanProperty( + properties: Properties.T, + name: String + ): Option[Boolean] = + Properties.get(properties, name).flatMap(Value.Boolean.unapply) + + private def bucketUpperBoundMicros(bucket: Int): Long = + if (bucket >= 62) Long.MaxValue + else (1L << (bucket + 1)) - 1L +} diff --git a/Fine_Grained_Timing/src/FineGrainedTimingDockable.scala b/Fine_Grained_Timing/src/FineGrainedTimingDockable.scala new file mode 100644 index 00000000..2a3e5404 --- /dev/null +++ b/Fine_Grained_Timing/src/FineGrainedTimingDockable.scala @@ -0,0 +1,432 @@ +/* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT */ + +import java.awt.{BorderLayout, FlowLayout} +import java.awt.event.{ActionEvent, ActionListener, MouseAdapter, MouseEvent} +import javax.swing.{ + JCheckBox, + JComboBox, + JLabel, + JPanel, + JScrollPane, + JTable, + JTextField +} +import javax.swing.table.AbstractTableModel + +import scala.collection.mutable +import scala.annotation.unused + +import isabelle.{Command, Document, GUI_Thread, Markup, Session, Text} +import isabelle.jedit.PIDE + +import org.gjt.sp.jedit.View +import org.gjt.sp.jedit.gui.DefaultFocusComponent + +class FineGrainedTimingDockable(view: View, @unused position: String) +extends JPanel(new BorderLayout) with DefaultFocusComponent { + private val ScopeCommand = "Command" + private val ScopeProof = "Proof" + private val ScopeTheory = "Theory" + private val ScopeGlobal = "Global" + private val CallsView = "Calls" + private val AggregateView = "Aggregate" + + private val columns = + Vector("Location", "Name", "Outcome", "Count", "Total", "Average", + "p50", "p90", "p99", "Min", "Max", "CPU", "GC") + + private final case class CommandTiming( + command: Command, + index: Int, + theory: String, + invocations: Vector[FineGrainedTiming.Invocation] + ) + + private sealed trait TimingRow { + def command: Command + def values: Vector[String] + } + + private final case class InvocationRow( + command: Command, + location: String, + invocation: FineGrainedTiming.Invocation + ) extends TimingRow { + def values: Vector[String] = { + val sampleCount = invocation.samples.iterator.map(_.aggregate.count).sum + val elapsed = invocation.timing.map(timing => formatMicros(timing.elapsedMicros)) + val cpu = invocation.timing.map(timing => formatMicros(timing.cpuMicros)) + val gc = invocation.timing.map(timing => formatMicros(timing.gcMicros)) + Vector( + location, + invocation.method, + if (invocation.success) "success" else "failure", + sampleCount.toString, + elapsed.getOrElse(""), + "", + "", + "", + "", + "", + "", + cpu.getOrElse(""), + gc.getOrElse("") + ) + } + } + + private final case class AggregateRow( + command: Command, + location: String, + key: FineGrainedTiming.SampleKey, + aggregate: FineGrainedTiming.Aggregate + ) extends TimingRow { + def values: Vector[String] = + Vector( + location, + key.name, + if (key.success) "success" else "failure", + aggregate.count.toString, + formatMicros(aggregate.timing.elapsedMicros), + formatMicros(aggregate.averageElapsedMicros), + formatMicros(aggregate.percentileElapsedMicros(0.50)), + formatMicros(aggregate.percentileElapsedMicros(0.90)), + formatMicros(aggregate.percentileElapsedMicros(0.99)), + formatMicros(aggregate.minElapsedMicros), + formatMicros(aggregate.maxElapsedMicros), + formatMicros(aggregate.timing.cpuMicros), + formatMicros(aggregate.timing.gcMicros) + ) + } + + private final class TimingTableModel extends AbstractTableModel { + private var rows = Vector.empty[TimingRow] + + def update(newRows: Vector[TimingRow]): Unit = { + rows = newRows + fireTableDataChanged() + } + + def row(index: Int): Option[TimingRow] = rows.lift(index) + + override def getRowCount: Int = rows.length + override def getColumnCount: Int = columns.length + override def getColumnName(column: Int): String = columns(column) + override def getValueAt(row: Int, column: Int): Object = rows(row).values(column) + } + + private val tableModel = new TimingTableModel + private val table = new JTable(tableModel) + table.setAutoCreateRowSorter(true) + table.setFillsViewportHeight(true) + table.addMouseListener(new MouseAdapter { + override def mouseClicked(event: MouseEvent): Unit = { + if (event.getClickCount == 2) { + val viewRow = table.rowAtPoint(event.getPoint) + if (viewRow >= 0) { + val modelRow = table.convertRowIndexToModel(viewRow) + for { + row <- tableModel.row(modelRow) + hyperlink <- PIDE.editor.hyperlink_command( + PIDE.session.snapshot(), row.command.id, focus = true) + } hyperlink.follow(view) + } + } + } + }) + + private val scopeSelector = + new JComboBox[String](Array(ScopeCommand, ScopeProof, ScopeTheory, ScopeGlobal)) + private val viewSelector = + new JComboBox[String](Array(AggregateView, CallsView)) + private val categorySelector = + new JComboBox[String]( + Array("all", "branch", "step", "call", "clarsimp", "seplog", + "transaction", "setup", "other") + ) + private val showSuccess = new JCheckBox("Success", true) + private val showFailure = new JCheckBox("Failure", true) + private val thresholdField = new JTextField("0.000", 6) + private val currentLabel = new JLabel("No active theory") + + private val refreshListener = new ActionListener { + override def actionPerformed(event: ActionEvent): Unit = { + val _ = event + refresh() + } + } + scopeSelector.addActionListener(refreshListener) + viewSelector.addActionListener(refreshListener) + categorySelector.addActionListener(refreshListener) + showSuccess.addActionListener(refreshListener) + showFailure.addActionListener(refreshListener) + thresholdField.addActionListener(refreshListener) + + private val controls = new JPanel(new FlowLayout(FlowLayout.LEFT, 6, 2)) + controls.add(new JLabel("Scope:")) + controls.add(scopeSelector) + controls.add(new JLabel("View:")) + controls.add(viewSelector) + controls.add(new JLabel("Category:")) + controls.add(categorySelector) + controls.add(showSuccess) + controls.add(showFailure) + controls.add(new JLabel("Threshold (s):")) + controls.add(thresholdField) + controls.add(currentLabel) + + add(controls, BorderLayout.NORTH) + add(new JScrollPane(table), BorderLayout.CENTER) + + private var globalTimings = + Map.empty[Document.Node.Name, Vector[CommandTiming]] + + private def refresh( + changedNodes: Option[Set[Document.Node.Name]] = None + ): Unit = { + GUI_Thread.require {} + val sessionSnapshot = PIDE.session.snapshot() + if (globalTimings.nonEmpty) updateGlobalTimings(sessionSnapshot, changedNodes) + + if (scopeSelector.getSelectedItem.toString == ScopeGlobal) { + if (globalTimings.isEmpty) updateGlobalTimings(sessionSnapshot, None) + val selected = globalTimings.toVector.sortBy(_._1.theory).flatMap(_._2) + val theoryCount = + selected.iterator.filter(_.invocations.nonEmpty).map(_.theory).toSet.size + val location = s"Global: $theoryCount theories" + currentLabel.setText(location) + tableModel.update(makeRows(selected, location)) + } else PIDE.editor.current_node_snapshot(view) match { + case Some(snapshot) if !snapshot.is_outdated => + val node = snapshot.node + val commandPairs = node.command_iterator().toVector + val scopeCommands = + commandPairs.map { case (command, offset) => + FineGrainedTimingScope.ScopeCommand(command.span.name, offset, command.length) + } + val proofs = FineGrainedTimingScope.partitionNamedProofs(scopeCommands) + val currentCommand = PIDE.editor.current_command(view, snapshot) + val currentIndex = + currentCommand.flatMap(command => commandPairs.indexWhere(_._1.id == command.id) match { + case index if index >= 0 => Some(index) + case _ => None + }) + val timings = + commandPairs.zipWithIndex.map { case ((command, offset), index) => + CommandTiming( + command, index, snapshot.node_name.theory, + invocations(snapshot, command, offset)) + } + val selected = selectedCommands(timings, currentIndex, proofs) + val location = selectedLocation(snapshot, currentIndex, proofs, commandPairs) + currentLabel.setText(location) + tableModel.update(makeRows(selected, location)) + case _ => + currentLabel.setText("No active theory") + tableModel.update(Vector.empty) + } + } + + private def updateGlobalTimings( + snapshot: Document.Snapshot, + changedNodes: Option[Set[Document.Node.Name]] + ): Unit = { + val domain = + snapshot.version.nodes.names_iterator + .filter(name => name.is_theory && !PIDE.resources.loaded_theory(name)) + .toSet + val refreshNodes = + if (globalTimings.isEmpty) domain + else changedNodes.getOrElse(Set.empty).intersect(domain) + val retained = globalTimings.filter { case (name, _) => domain.contains(name) } + val refreshed = + refreshNodes.iterator.map { name => + val nodeSnapshot = snapshot.switch(name) + val timings = + nodeSnapshot.node.command_iterator().zipWithIndex.flatMap { + case ((command, offset), index) => + val reports = invocations(nodeSnapshot, command, offset) + if (reports.isEmpty) None + else Some(CommandTiming(command, index, name.theory, reports)) + }.toVector + name -> timings + }.toMap + globalTimings = retained ++ refreshed + } + + private def invocations( + snapshot: Document.Snapshot, + command: Command, + offset: Int + ): Vector[FineGrainedTiming.Invocation] = { + val range = Text.Range(offset, offset + command.length) + snapshot + .select[FineGrainedTiming.Invocation]( + range, + Markup.Elements(FineGrainedTiming.ReportMarkup), + _ => { + case Text.Info(_, tree) => FineGrainedTiming.decode(tree) + } + ) + .iterator + .map(_.info) + .toVector + .distinct + } + + private def selectedCommands( + timings: Vector[CommandTiming], + currentIndex: Option[Int], + proofs: IndexedSeq[FineGrainedTimingScope.NamedProof] + ): Vector[CommandTiming] = + scopeSelector.getSelectedItem.toString match { + case ScopeCommand => + currentIndex.flatMap(timings.lift).toVector + case ScopeProof => + currentIndex + .flatMap(index => FineGrainedTimingScope.namedProofAt(proofs, index)) + .map(proof => timings.slice(proof.startIndex, proof.endIndex + 1)) + .getOrElse(Vector.empty) + case ScopeTheory => + timings + case ScopeGlobal => + timings + case _ => + Vector.empty + } + + private def selectedLocation( + snapshot: Document.Snapshot, + currentIndex: Option[Int], + proofs: IndexedSeq[FineGrainedTimingScope.NamedProof], + commands: Vector[(Command, Int)] + ): String = + scopeSelector.getSelectedItem.toString match { + case ScopeCommand => + currentIndex + .flatMap(commands.lift) + .map { case (command, _) => s"Command: ${command.span.name}" } + .getOrElse("Command: none") + case ScopeProof => + currentIndex + .flatMap(index => FineGrainedTimingScope.namedProofAt(proofs, index)) + .flatMap(proof => commands.lift(proof.startIndex)) + .map { case (command, _) => s"Proof: ${proofName(command)}" } + .getOrElse("Proof: none") + case ScopeTheory => + s"Theory: ${snapshot.node_name.theory}" + case ScopeGlobal => + "Global" + case _ => + "" + } + + private def makeRows( + commands: Vector[CommandTiming], + location: String + ): Vector[TimingRow] = { + val threshold = thresholdMicros + val successEnabled = showSuccess.isSelected + val failureEnabled = showFailure.isSelected + if (viewSelector.getSelectedItem.toString == CallsView) { + commands.iterator + .flatMap(command => + command.invocations.iterator.map(invocation => + InvocationRow( + command.command, + if (scopeSelector.getSelectedItem.toString == ScopeGlobal) + s"${command.theory}: ${command.command.span.name}" + else location, + invocation))) + .filter(row => if (row.invocation.success) successEnabled else failureEnabled) + .filter(row => + row.invocation.timing.forall(_.elapsedMicros.toDouble >= threshold)) + .toVector + .sortBy(row => -row.invocation.timing.map(_.elapsedMicros).getOrElse(0L)) + } else { + val merged = + mutable.LinkedHashMap.empty[ + FineGrainedTiming.SampleKey, + (FineGrainedTiming.Aggregate, Command) + ] + commands.foreach { command => + FineGrainedTiming.aggregate(command.invocations).foreach { case (key, aggregate) => + merged.updateWith(key) { + case Some((existing, firstCommand)) => + Some((existing + aggregate, firstCommand)) + case None => + Some((aggregate, command.command)) + } + } + } + merged.iterator + .map { case (key, (aggregate, command)) => + AggregateRow(command, location, key, aggregate) + } + .filter(row => if (row.key.success) successEnabled else failureEnabled) + .filter(row => categoryMatches(row.key.name)) + .filter(_.aggregate.timing.elapsedMicros.toDouble >= threshold) + .toVector + .sortBy(row => -row.aggregate.timing.elapsedMicros) + } + } + + private def categoryMatches(name: String): Boolean = { + val selected = categorySelector.getSelectedItem.toString + selected == "all" || category(name) == selected + } + + private def category(name: String): String = { + val lower = name.toLowerCase + if (lower.contains("clarsimp")) "clarsimp" + else if (lower.contains("seplog") || lower.contains("aentails")) "seplog" + else if (lower.contains("transaction")) "transaction" + else if (lower.contains("call")) "call" + else if (lower.contains("setup") || lower.contains("instantiation")) "setup" + else if (lower.contains("step")) "step" + else if (lower.contains("branch")) "branch" + else "other" + } + + private def proofName(command: Command): String = { + val pattern = + """(?s)^\s*(?:lemma|theorem|corollary|proposition|schematic_goal)\s+([A-Za-z0-9_']+)""".r + pattern.findFirstMatchIn(command.source).map(_.group(1)) + .getOrElse(command.span.name) + } + + private def thresholdMicros: Double = + try math.max(0.0, thresholdField.getText.trim.toDouble) * 1000000.0 + catch { case _: NumberFormatException => 0.0 } + + private def formatMicros(micros: Long): String = + f"${micros.toDouble / 1000000.0}%.6fs" + + private def formatMicros(micros: Double): String = + f"${micros / 1000000.0}%.6fs" + + private val main = + Session.Consumer[Any](getClass.getName) { + case changed: Session.Commands_Changed => + GUI_Thread.later { refresh(Some(changed.nodes)) } + case Session.Caret_Focus => + GUI_Thread.later { refresh() } + case _ => + } + + override def addNotify(): Unit = { + super.addNotify() + PIDE.session.commands_changed += main + PIDE.session.caret_focus += main + refresh() + } + + override def removeNotify(): Unit = { + PIDE.session.caret_focus -= main + PIDE.session.commands_changed -= main + super.removeNotify() + } + + def focusOnDefaultComponent(): Unit = table.requestFocus() +} diff --git a/Fine_Grained_Timing/src/FineGrainedTimingPlugin.scala b/Fine_Grained_Timing/src/FineGrainedTimingPlugin.scala new file mode 100644 index 00000000..17dd6f15 --- /dev/null +++ b/Fine_Grained_Timing/src/FineGrainedTimingPlugin.scala @@ -0,0 +1,6 @@ +/* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT */ + +import org.gjt.sp.jedit.EBPlugin + +class FineGrainedTimingPlugin extends EBPlugin diff --git a/Fine_Grained_Timing/src/FineGrainedTimingScope.scala b/Fine_Grained_Timing/src/FineGrainedTimingScope.scala new file mode 100644 index 00000000..219c71bc --- /dev/null +++ b/Fine_Grained_Timing/src/FineGrainedTimingScope.scala @@ -0,0 +1,62 @@ +/* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT */ + +object FineGrainedTimingScope { + final case class ScopeCommand(name: String, offset: Int, length: Int) + + final case class NamedProof( + startIndex: Int, + endIndex: Int, + startOffset: Int, + endOffset: Int + ) + + private val NamedProofStarters: Set[String] = + Set("lemma", "theorem", "corollary", "proposition", "schematic_goal") + + def partitionNamedProofs(commands: IndexedSeq[ScopeCommand]): IndexedSeq[NamedProof] = { + val result = Vector.newBuilder[NamedProof] + var i = 0 + while (i < commands.length) { + if (!NamedProofStarters.contains(commands(i).name)) { + i += 1 + } else { + var depth = 0 + var j = i + 1 + var endIndex = -1 + while (j < commands.length && endIndex < 0) { + commands(j).name match { + case "proof" => + depth += 1 + case "qed" => + if (depth <= 1) endIndex = j + else depth -= 1 + case "by" | "done" | "sorry" | "oops" if depth == 0 => + endIndex = j + case _ => + } + j += 1 + } + if (endIndex >= 0) { + val end = commands(endIndex) + result += NamedProof( + startIndex = i, + endIndex = endIndex, + startOffset = commands(i).offset, + endOffset = end.offset + end.length + ) + i = endIndex + 1 + } else { + i += 1 + } + } + } + result.result() + } + + def namedProofAt( + proofs: IndexedSeq[NamedProof], + commandIndex: Int + ): Option[NamedProof] = + proofs.find(proof => commandIndex >= proof.startIndex && commandIndex <= proof.endIndex) +} diff --git a/Fine_Grained_Timing/test/FineGrainedTimingScopeTest.scala b/Fine_Grained_Timing/test/FineGrainedTimingScopeTest.scala new file mode 100644 index 00000000..2f3afadc --- /dev/null +++ b/Fine_Grained_Timing/test/FineGrainedTimingScopeTest.scala @@ -0,0 +1,47 @@ +/* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT */ + +object FineGrainedTimingScopeTest { + private def requireThat(condition: Boolean, message: String): Unit = { + if (!condition) throw new RuntimeException(message) + } + + private def commands(names: String*): IndexedSeq[FineGrainedTimingScope.ScopeCommand] = { + var offset = 0 + names.map { name => + val command = FineGrainedTimingScope.ScopeCommand(name, offset, name.length) + offset += name.length + 1 + command + }.toIndexedSeq + } + + private def testNamedProofPartitioning(): Unit = { + val proofs = FineGrainedTimingScope.partitionNamedProofs(commands( + "text", + "lemma", "by", + "lemma", "proof", "have", "by", "show", "by", "qed", + "text" + )) + requireThat(proofs.length == 2, s"expected two named proofs, got ${proofs.length}") + requireThat(proofs.head.startIndex == 1 && proofs.head.endIndex == 2, + s"one-line proof partition is incorrect: ${proofs.head}") + requireThat(proofs(1).startIndex == 3 && proofs(1).endIndex == 9, + s"structured proof partition is incorrect: ${proofs(1)}") + requireThat(FineGrainedTimingScope.namedProofAt(proofs, 6).contains(proofs(1)), + "inner proof command should belong to the named outer proof") + requireThat(FineGrainedTimingScope.namedProofAt(proofs, 0).isEmpty, + "top-level text should not belong to a named proof") + } + + private def testIncompleteNamedProofIsExcluded(): Unit = { + val proofs = + FineGrainedTimingScope.partitionNamedProofs(commands("lemma", "proof", "show")) + requireThat(proofs.isEmpty, "an incomplete named proof should not be partitioned") + } + + def main(_args: Array[String]): Unit = { + testNamedProofPartitioning() + testIncompleteNamedProofIsExcluded() + println("FineGrainedTimingScopeTest: all tests passed") + } +} diff --git a/Fine_Grained_Timing/test/FineGrainedTimingTest.scala b/Fine_Grained_Timing/test/FineGrainedTimingTest.scala new file mode 100644 index 00000000..17bae759 --- /dev/null +++ b/Fine_Grained_Timing/test/FineGrainedTimingTest.scala @@ -0,0 +1,142 @@ +/* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT */ + +import isabelle.{Markup, Value, XML, YXML} + +object FineGrainedTimingTest { + private def requireThat(condition: Boolean, message: String): Unit = { + if (!condition) throw new RuntimeException(message) + } + + private def bucket(index: Int, count: Long): XML.Tree = + XML.Elem( + Markup( + FineGrainedTiming.BucketMarkup, + List("bucket" -> Value.Int(index), "count" -> Value.Long(count)) + ), + Nil + ) + + private def entry( + name: String, + success: Boolean, + count: Long, + elapsed: Long, + histogram: List[XML.Tree] + ): XML.Tree = + XML.Elem( + Markup( + FineGrainedTiming.EntryMarkup, + List( + "name" -> name, + "success" -> Value.Boolean(success), + "count" -> Value.Long(count), + "elapsed_us" -> Value.Long(elapsed), + "cpu_us" -> Value.Long(elapsed / 2), + "gc_us" -> Value.Long(elapsed / 4), + "min_elapsed_us" -> Value.Long(1), + "max_elapsed_us" -> Value.Long(elapsed) + ) + ), + histogram + ) + + private def report( + version: Int, + body: XML.Body + ): XML.Tree = + XML.Elem( + Markup( + FineGrainedTiming.ReportMarkup, + List( + "version" -> Value.Int(version), + "invocation" -> Value.Long(17L), + "method" -> "example_method", + "success" -> Value.Boolean(true) + ) ++ + (if (version == FineGrainedTiming.LegacySchemaVersion) + List( + "elapsed_us" -> Value.Long(100L), + "cpu_us" -> Value.Long(60L), + "gc_us" -> Value.Long(10L) + ) + else Nil) + ), + body + ) + + private def testDecodeNestedAndYxmlBodies(): Unit = { + val body = List(entry("branch", success = false, 3L, 7L, List(bucket(0, 1), bucket(1, 2)))) + val nested = + FineGrainedTiming.decode(report(FineGrainedTiming.SchemaVersion, body)) + val encoded = + FineGrainedTiming.decode( + report( + FineGrainedTiming.SchemaVersion, + List(XML.Text(YXML.string_of_body(body))) + ) + ) + requireThat(nested == encoded, "nested and YXML-text bodies should decode identically") + val invocation = nested.getOrElse(sys.error("expected a decoded invocation")) + requireThat(invocation.id == 17L, s"unexpected invocation id ${invocation.id}") + requireThat(invocation.timing.isEmpty, "version 2 should not contain implicit outer timing") + requireThat(invocation.samples.head.aggregate.count == 3L, "sample count was not decoded") + } + + private def testDecodeLegacyOuterTiming(): Unit = { + val invocation = + FineGrainedTiming + .decode(report(FineGrainedTiming.LegacySchemaVersion, Nil)) + .getOrElse(sys.error("expected a decoded legacy invocation")) + requireThat( + invocation.timing.contains(FineGrainedTiming.Timing(100L, 60L, 10L)), + "version 1 outer timing was not decoded" + ) + } + + private def testRejectMalformedHistogram(): Unit = { + val malformed = + report( + FineGrainedTiming.SchemaVersion, + List(entry("branch", success = true, 2L, 5L, List(bucket(0, 1)))) + ) + requireThat(FineGrainedTiming.decode(malformed).isEmpty, "histogram count mismatch should be rejected") + } + + private def testAssociativeMergeAndPercentiles(): Unit = { + val a = FineGrainedTiming.Aggregate( + 1L, + FineGrainedTiming.Timing(1L, 1L, 0L), + 1L, + 1L, + Map(0 -> 1L) + ) + val b = FineGrainedTiming.Aggregate( + 2L, + FineGrainedTiming.Timing(6L, 2L, 0L), + 2L, + 4L, + Map(1 -> 1L, 2 -> 1L) + ) + val c = FineGrainedTiming.Aggregate( + 1L, + FineGrainedTiming.Timing(8L, 4L, 1L), + 8L, + 8L, + Map(3 -> 1L) + ) + requireThat((a + b) + c == a + (b + c), "aggregate merge should be associative") + val merged = a + b + c + requireThat(merged.averageElapsedMicros == 3.75, "average elapsed time is incorrect") + requireThat(merged.percentileElapsedMicros(0.5) == 3L, "p50 bucket is incorrect") + requireThat(merged.percentileElapsedMicros(0.99) == 15L, "p99 bucket is incorrect") + } + + def main(_args: Array[String]): Unit = { + testDecodeNestedAndYxmlBodies() + testDecodeLegacyOuterTiming() + testRejectMalformedHistogram() + testAssociativeMergeAndPercentiles() + println("FineGrainedTimingTest: all tests passed") + } +} diff --git a/Fine_Grained_Timing/test/Fine_Grained_Timing_Test.thy b/Fine_Grained_Timing/test/Fine_Grained_Timing_Test.thy new file mode 100644 index 00000000..b967ceb5 --- /dev/null +++ b/Fine_Grained_Timing/test/Fine_Grained_Timing_Test.thy @@ -0,0 +1,184 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +theory Fine_Grained_Timing_Test + imports "Fine_Grained_Timing.Fine_Grained_Timing" +begin + +ML \ + val reports = 256 + val accumulator = Fine_Grained_Timing_Accumulator.create "concurrent timing test" + val timing: Timing.timing = { + elapsed = Time.fromMicroseconds 1, + cpu = Time.zeroTime, + gc = Time.zeroTime + } + val futures = + map (fn _ => + Future.fork (fn () => + Fine_Grained_Timing_Accumulator.add accumulator ("test", true, timing))) + (1 upto reports) + val _ = List.app Future.join futures + val actual = + accumulator + |> Fine_Grained_Timing_Accumulator.value + |> Fine_Grained_Timing_Accumulator.total_samples + val _ = + if actual = reports then () + else error ("Lost concurrent timing reports: expected " ^ + Value.print_int reports ^ ", got " ^ Value.print_int actual) + + val first_samples = + Synchronized.var "first timing test sink" + ([]: (string * bool) list) + val second_samples = + Synchronized.var "second timing test sink" + ([]: (string * bool) list) + + fun test_sink samples _ = + SOME (fn {name, success, ...}: Fine_Grained_Timing.timing_result => + Synchronized.change samples (cons (name, success))) + + val sink_context = + @{context} + |> Fine_Grained_Timing.add_sink "test_first" + (test_sink first_samples) + |> Fine_Grained_Timing.add_sink "test_inactive" (K NONE) + |> Fine_Grained_Timing.add_sink "test_second" + (test_sink second_samples) + + val sink_result = + Fine_Grained_Timing.time_and_report sink_context "fanout" true + (fn () => 42) + val failed_sink_result = + Fine_Grained_Timing.time_seq sink_context "failed_fanout" + (K Seq.empty) () + |> Seq.pull + + val _ = + if sink_result = 42 andalso is_none failed_sink_result andalso + Synchronized.value first_samples = + [("failed_fanout", false), ("fanout", true)] andalso + Synchronized.value second_samples = + [("failed_fanout", false), ("fanout", true)] + then () + else error "Timing sample was not delivered once to every active sink" + + val removed_context = + Fine_Grained_Timing.remove_sink "test_first" sink_context + val _ = + Fine_Grained_Timing.time_and_report removed_context "after_remove" true + (fn () => ()) + val _ = + if Synchronized.value first_samples = + [("failed_fanout", false), ("fanout", true)] andalso + Synchronized.value second_samples = + [("after_remove", true), ("failed_fanout", false), + ("fanout", true)] + then () + else error "Removing a timing sink changed the wrong destination" + + val inactive_runs = Synchronized.var "inactive timing test" 0 + val inactive_context = + @{context} + |> Fine_Grained_Timing.add_sink "test_inactive_only" (K NONE) + + val inactive_result = + Fine_Grained_Timing.time_and_report inactive_context "inactive" true + (fn () => + (Synchronized.change inactive_runs (fn count => count + 1); + "result")) + + val _ = + if inactive_result = "result" andalso + Synchronized.value inactive_runs = 1 + then () + else error "Timing without an active sink changed the wrapped operation" + + val profile_context = + Config.put Fine_Grained_Timing.enabled true @{context} + val profile_result = + Fine_Grained_Timing.profile_seq "generic_profile" profile_context + (fn ctxt => Seq.single (Fine_Grained_Timing.active ctxt)) + |> Seq.pull + + val _ = + (case profile_result of + SOME (true, _) => () + | _ => error "Generic profile did not install its accumulator context") + val _ = + if Fine_Grained_Timing.active profile_context then + error "Generic profile changed its input context" + else () +\ + +method_setup assert_no_fine_grained_profile = + \Scan.succeed (fn ctxt => + if Fine_Grained_Timing.active ctxt then Method.fail + else Method.succeed)\ + +lemma standalone_time_is_transparent: + assumes A: \PROP P\ + shows \PROP P\ + by (time "standalone_time" \rule A\) + +lemma disabled_profile_is_transparent: + assumes A: \PROP P\ + shows \PROP P\ + by (profile "disabled_profile" \rule A\) + +declare [[fine_grained_timing = true, fine_grained_timing_threshold = -1]] + +lemma standalone_time_with_timing_enabled_is_transparent: + assumes A: \PROP P\ + shows \PROP P\ + by (time "standalone_time_enabled" \rule A\) + +declare [[fine_grained_timing_output = true]] + +lemma standalone_time_can_report_to_output: + assumes A: \PROP P\ + shows \PROP P\ + by (time "output_sample" \rule A\) + +declare [[fine_grained_timing_output = false]] + +lemma profile_without_inner_samples: + assumes A: \PROP P\ + shows \PROP P\ + by (profile "outer_only" \rule A\) + +lemma profile_with_successful_sample: + assumes A: \PROP P\ + shows \PROP P\ + by (profile "nested_success" + \time "successful_sample" \rule A\\) + +lemma profile_with_failed_sample: + assumes A: \PROP P\ + shows \PROP P\ + by (profile "nested_failure" + \(time "failed_sample" \fail\) | rule A\) + +lemma nested_profiles_use_the_innermost_accumulator: + assumes A: \PROP P\ + shows \PROP P\ + by (profile "nested_outer" + \time "outer_before" \succeed\, + profile "nested_inner" \time "inner_sample" \succeed\\, + time "outer_after" \rule A\\) + +lemma failed_profile_preserves_backtracking: + assumes A: \PROP P\ + shows \PROP P\ + by ((profile "failed_profile" \fail\) | rule A) + +lemma profile_accumulator_does_not_escape: + assumes A: \PROP P\ + shows \PROP P\ + apply (profile "context_scope" \succeed\) + apply assert_no_fine_grained_profile + apply (rule A) + done + +end diff --git a/Fine_Grained_Timing/test/ROOT b/Fine_Grained_Timing/test/ROOT new file mode 100644 index 00000000..af231992 --- /dev/null +++ b/Fine_Grained_Timing/test/ROOT @@ -0,0 +1,3 @@ +session Fine_Grained_Timing_Test = Fine_Grained_Timing + + theories + Fine_Grained_Timing_Test diff --git a/Fine_Grained_Timing/time.ML b/Fine_Grained_Timing/time.ML new file mode 100644 index 00000000..45957017 --- /dev/null +++ b/Fine_Grained_Timing/time.ML @@ -0,0 +1,625 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(* +Fine-grained timing for custom tactics +====================================== + +This file has three jobs: + + 1. measure named operations only when at least one sink wants the sample; + 2. deliver each sample to all active sinks; and + 3. let `profile` bundle PIDE samples into one report. + +Sink factories are stored in the proof context. A factory receives the current +context and returns either an active callback or `NONE`. The two default +factories are: + + - the PIDE sink, active when `fine_grained_timing` is enabled and `profile` + has pushed an accumulator into the context; and + - the output sink, active when `fine_grained_timing_output` is enabled. + +`time` resolves the factories before doing any measurement. With no callbacks, +it runs the wrapped operation unchanged. Otherwise it measures one lazy +sequence pull and sends the same result to every callback. + +For example, output can be enabled without opening a PIDE profile: + + declare [[fine_grained_timing_output = true]] + apply (time "normalization" ‹simp›) + +A producer can add another destination in a derived context: + + fun file_sink ctxt = + if my_option ctxt then + SOME (fn {name, success, timing} => write_sample name success timing) + else NONE + + val timed_ctxt = + Fine_Grained_Timing.add_sink "file" file_sink ctxt + +The factory, rather than the callback, receives the proof context. This lets a +sink inspect configuration once for each `time` wrapper. If the factory returns +`NONE`, that destination adds no measurement overhead beyond sink resolution. + +`profile` does not measure its wrapped operation. It pushes a fresh synchronized +PIDE accumulator, performs one ordinary sequence pull, and emits one report +containing the samples produced by nested `time` wrappers. To include a total, +write it explicitly: + + apply (profile ‹time "total" ‹my_method››) + +Nested profiles push another accumulator. The PIDE sink writes only to the top +stack frame, so the inner samples are not counted again by the outer profile. +After the inner profile returns, later samples go to the outer frame. + +One report per profile is deliberate. A method may produce millions of +samples; aggregation keeps PIDE traffic bounded. +*) + +signature FINE_GRAINED_TIMING = +sig + type logger = Pretty.T -> unit + type timing_result = { + name: string, + success: bool, + timing: Timing.timing + } + type sink = timing_result -> unit + type sink_factory = Proof.context -> sink option + + val add_sink : + string -> sink_factory -> Proof.context -> Proof.context + val remove_sink : + string -> Proof.context -> Proof.context + + (* Time a tactic and record the result under the supplied sample name. + The boolean is a cheap producer-side switch: false runs the tactic + unchanged. The primed form decorates an int-indexed tactic. *) + val TIME : Proof.context -> bool -> string -> tactic -> tactic + val TIME' : Proof.context -> bool -> string -> (int -> tactic) -> (int -> tactic) + + (* Compatibility variants for callers that already carry positions, + loggers, or a callback. The extra arguments remain useful to existing + tactic instrumentation. *) + val TIME_pos : Proof.context -> Position.T -> bool -> string -> logger -> tactic -> tactic + val TIME_pos' : Proof.context -> Position.T -> bool -> string -> logger + -> (int -> tactic) -> (int -> tactic) + + val TIME_CB : Proof.context -> Position.T -> bool -> string -> logger + -> (thm -> thm option -> Timing.timing -> bool -> unit) + -> tactic -> tactic + val TIME_CB' : Proof.context -> Position.T -> bool -> string -> logger + -> (thm -> thm option -> Timing.timing -> bool -> unit) + -> (int -> tactic) -> (int -> tactic) + + val report : Proof.context -> timing_result -> unit + + (* `measure_seq` always measures one lazy pull and invokes its callback. + `time_seq` first resolves the context sinks and remains transparent when + none are active. *) + val measure_seq : ('b -> 'a option -> Timing.timing -> bool -> unit) + -> ('b -> 'a Seq.seq) -> 'b -> 'a Seq.seq + val time_seq : + Proof.context -> string -> ('b -> 'a Seq.seq) -> 'b -> 'a Seq.seq + val time_method : + string -> (Proof.context -> Method.method) -> Method.method + + val enabled : bool Config.T + val output_enabled : bool Config.T + val timing_threshold_us : int Config.T + val active : Proof.context -> bool + + val time_it : (unit -> 'a) -> (unit -> Timing.timing * 'a) + val time_and_report : Proof.context -> string -> bool -> (unit -> 'a) -> 'a + val time_it_with_status : (unit -> 'a) -> ('a -> bool) + -> (unit -> (Timing.timing * bool) * 'a) + + (* Create one PIDE aggregation boundary around an arbitrary lazy sequence. + The string is the invocation label shown in the report header. *) + val profile_seq : + string -> Proof.context -> (Proof.context -> 'a Seq.seq) -> 'a Seq.seq + + val profile_tactic : + string -> Proof.context -> (Proof.context -> tactic) -> tactic + + val profile_method : + string -> (Proof.context -> Method.method) -> Method.method +end; + +(* +The accumulator stores already-merged statistics, not raw samples. + +For example, three successful "normalize" samples and two failed ones +produce two AggregateStatistics records under the same name. This split is +important for tactics: a branch that fails is often expected control flow, +but its cost still matters. + +`Synchronized.var` makes updates safe when a tactic forks worker futures. +The outer tactic is expected to join its ordinary worker activity before +returning. Detached work is outside the invocation lifetime and must not +continue recording after the outer sequence has finished. +*) +structure Fine_Grained_Timing_Accumulator = +struct + (* Histogram keys are floor(log2(elapsed microseconds)). Thus bucket 10 + represents samples whose elapsed time is around 2^10 microseconds. + Fixed buckets are cheap to merge and allow the Scala side to estimate + percentiles without retaining every sample. *) + type AggregateStatistics = { + samples: int, + total_elapsed: Time.time, + total_cpu: Time.time, + total_gc: Time.time, + min_elapsed: Time.time option, + max_elapsed: Time.time option, + histogram: int Inttab.table + } + + type IndividualStatistics = { + successes: AggregateStatistics, + failures: AggregateStatistics + } + + type Statistics = IndividualStatistics Symtab.table + type T = Statistics Synchronized.var + + val aggregate_statistics_empty: AggregateStatistics = { + samples = 0, + total_elapsed = Time.zeroTime, + total_cpu = Time.zeroTime, + total_gc = Time.zeroTime, + min_elapsed = NONE, + max_elapsed = NONE, + histogram = Inttab.empty + } + + val individual_statistics_empty: IndividualStatistics = { + successes = aggregate_statistics_empty, + failures = aggregate_statistics_empty + } + + fun create name = Synchronized.var name Symtab.empty + + (* Zero and one microsecond both land in bucket zero. Larger values use + their integer base-2 logarithm. *) + fun elapsed_bucket (timing: Timing.timing) = + let + fun log2 n acc = + if n <= 1 then acc + else log2 (n div 2) (acc + 1) + in log2 (Time.toMicroseconds (#elapsed timing)) 0 end + + fun add_aggregate_timing (timing: Timing.timing) ({ + samples, + total_elapsed, + total_cpu, + total_gc, + min_elapsed, + max_elapsed, + histogram + }: AggregateStatistics) = + let + val elapsed = #elapsed timing + val min_elapsed' = + (case min_elapsed of + NONE => SOME elapsed + | SOME t => SOME (if Time.< (elapsed, t) then elapsed else t)) + val max_elapsed' = + (case max_elapsed of + NONE => SOME elapsed + | SOME t => SOME (if Time.< (t, elapsed) then elapsed else t)) + val histogram' = + Inttab.map_default (elapsed_bucket timing, 0) (fn n => n + 1) histogram + in + { + samples = samples + 1, + total_elapsed = total_elapsed + elapsed, + total_cpu = total_cpu + #cpu timing, + total_gc = total_gc + #gc timing, + min_elapsed = min_elapsed', + max_elapsed = max_elapsed', + histogram = histogram' + } + end + + fun add_report (name, success, timing: Timing.timing) = + Symtab.map_default (name, individual_statistics_empty) + (fn ({successes, failures}: IndividualStatistics) => + if success then + {successes = add_aggregate_timing timing successes, failures = failures} + else + {successes = successes, failures = add_aggregate_timing timing failures}) + + fun add accumulator timing_report = + Synchronized.change accumulator (add_report timing_report) + + (* Reading is synchronized as well. Final PIDE encoding sees one complete + snapshot of all updates that happened before this call. *) + val value = Synchronized.value + + fun total_samples (statistics: Statistics) = + Symtab.fold + (fn (_, {successes, failures}: IndividualStatistics) => + fn total => total + #samples successes + #samples failures) + statistics 0 + + fun encode_time t = Value.print_int (Time.toMicroseconds t) + + (* + Aggregate body format, shared by report schemas 1 and 2: + + + + + + + There is one entry for each (sample name, success) pair with a non-zero + count. Times in an entry are totals except for the explicit minimum and + maximum fields. + *) + fun encode_aggregate name success ({ + samples, + total_elapsed, + total_cpu, + total_gc, + min_elapsed, + max_elapsed, + histogram + }: AggregateStatistics) = + if samples = 0 then [] + else + let + val properties = [ + ("name", name), + ("success", Bool.toString success), + ("count", Value.print_int samples), + ("elapsed_us", encode_time total_elapsed), + ("cpu_us", encode_time total_cpu), + ("gc_us", encode_time total_gc), + ("min_elapsed_us", encode_time (the min_elapsed)), + ("max_elapsed_us", encode_time (the max_elapsed)) + ] + val buckets = + Inttab.dest histogram + |> map (fn (bucket, count) => + XML.Elem (("fine_grained_timing_bucket", [ + ("bucket", Value.print_int bucket), + ("count", Value.print_int count) + ]), [])) + in [XML.Elem (("fine_grained_timing_entry", properties), buckets)] end + + fun encode statistics = + Symtab.dest statistics + |> maps (fn (name, {successes, failures}: IndividualStatistics) => + encode_aggregate name true successes @ + encode_aggregate name false failures) +end; + +(* +`Fine_Grained_Timing` is the producer-facing API. Invocation names and sample +names are opaque labels: the timing layer records and transports them without +assigning producer-specific meaning. +*) +structure Fine_Grained_Timing: FINE_GRAINED_TIMING = +struct + type logger = Pretty.T -> unit + type timing_result = { + name: string, + success: bool, + timing: Timing.timing + } + type sink = timing_result -> unit + type sink_factory = Proof.context -> sink option + + (* Registered components supply the system defaults. Importing only the + session remains safe: an unknown option falls back to false. *) + val enabled = + Attrib.setup_config_bool @{binding "fine_grained_timing"} + (fn _ => + Options.default_bool "fine_grained_timing" + handle ERROR _ => false) + + val output_enabled = + Attrib.setup_config_bool @{binding "fine_grained_timing_output"} + (fn _ => + Options.default_bool "fine_grained_timing_output" + handle ERROR _ => false) + + val timing_threshold_us = + Attrib.setup_config_int @{binding "fine_grained_timing_threshold"} (K 2000) + + type pide_invocation = { + id: int, + invocation_name: string, + position: Position.T, + statistics: Fine_Grained_Timing_Accumulator.T + } + + (* The stack itself is immutable context data. Each entry is a fresh + synchronized accumulator, so parallel commands cannot interfere and a + nested profile can shadow its parent without clearing parent state. *) + structure PIDE_Profiles = Proof_Data ( + type T = Fine_Grained_Timing_Accumulator.T list + val init = K []) + + fun active ctxt = not (null (PIDE_Profiles.get ctxt)) + + (* + PIDE report schema version 2: + + + ...encoded aggregate entries... + + + The header deliberately has no implicit outer timing. `profile` controls + the accumulator lifetime but does not generate a measurement. Users who + need a total add an explicit outer `time` wrapper. + + The aggregate entries are passed as YXML text because report markup has a + text payload. The Scala decoder accepts this representation and the nested + XML form used by tests. Position-attached markup follows PIDE document + lifetime, so edited commands do not leave stale reports. + *) + fun emit_pide_report ctxt + ({id, invocation_name, position, statistics}: pide_invocation) success = + let + val properties = [ + ("version", "2"), + ("invocation", Value.print_int id), + ("method", invocation_name), + ("success", Bool.toString success) + ] + val body = Fine_Grained_Timing_Accumulator.encode + (Fine_Grained_Timing_Accumulator.value statistics) + in + Context_Position.report_text ctxt position + ("fine_grained_timing", properties) (YXML.string_of_body body) + end + + fun above_pide_threshold ctxt ({timing, ...}: timing_result) = + let val threshold = Time.fromMicroseconds (Config.get ctxt timing_threshold_us) + in #elapsed timing > threshold end + + fun pide_sink_factory ctxt = + if not (Config.get ctxt enabled) then NONE + else + (case PIDE_Profiles.get ctxt of + [] => NONE + | statistics :: _ => + SOME (fn result as {name, success, timing} => + if above_pide_threshold ctxt result then + Fine_Grained_Timing_Accumulator.add statistics + (name, success, timing) + else ())) + + fun output_sink_factory ctxt = + if Config.get ctxt output_enabled then + SOME (fn {name, success, timing} => + tracing ("fine-grained timing " ^ quote name ^ " " ^ + (if success then "success" else "failure") ^ ": " ^ + Timing.message timing)) + else NONE + + structure Sink_Data = Proof_Data ( + type T = sink_factory Symtab.table + val init = K (Symtab.make [ + ("pide", pide_sink_factory), + ("output", output_sink_factory) + ])) + + fun add_sink name factory = + Sink_Data.map (Symtab.update (name, factory)) + + fun remove_sink name = + Sink_Data.map (Symtab.delete_safe name) + + fun resolve_sinks ctxt = + Sink_Data.get ctxt + |> Symtab.dest + |> map_filter (fn (_, factory) => factory ctxt) + + fun dispatch sinks result = + List.app (fn sink => sink result) sinks + + fun report ctxt result = + dispatch (resolve_sinks ctxt) result + + fun time_it_with_status f is_good () = + let + val start = Timing.start () + val result = f () + val timing = Timing.result start + in ((timing, is_good result), result) end + + fun time_it f = + time_it_with_status f (K true) #> apfst fst + + fun time_and_report ctxt name producer_enabled f = + if not producer_enabled then f () + else + (case resolve_sinks ctxt of + [] => f () + | sinks => + let + val (timing, result) = time_it f () + val _ = dispatch sinks { + name = name, + success = true, + timing = timing + } + in result end) + + (* + `measure_seq` is the unconditional low-level timing primitive retained for + callers that need theorem-aware callbacks. `time_seq` is the sink-aware + public operation: it resolves callbacks before constructing the wrapper and + leaves the original sequence untouched when none are active. + + Both wrappers measure one pull only. A pull searches until the sequence + yields its first result or is exhausted; the returned tail remains lazy and + untouched. + *) + fun measure_seq callback sequence = + fn input => Seq.make (fn _ => + let + val ((timing, success), output) = + time_it_with_status (fn _ => Seq.pull (sequence input)) is_some () + val _ = callback input (Option.map fst output) timing success + in output end) + + fun time_seq ctxt name sequence input = + (case resolve_sinks ctxt of + [] => sequence input + | sinks => + let + fun callback _ _ timing success = + dispatch sinks { + name = name, + success = success, + timing = timing + } + in measure_seq callback sequence input end) + + fun time_method name make_method facts context = + let + val ctxt = fst context + val method = make_method ctxt + in time_seq ctxt name (method facts) context end + + fun TIME_CB ctxt _ producer_enabled name _ user_callback tactic theorem = + if not producer_enabled then tactic theorem + else + let + val sinks = resolve_sinks ctxt + fun callback input output timing success = + (user_callback input output timing success; + dispatch sinks { + name = name, + success = success, + timing = timing + }) + in measure_seq callback tactic theorem end + + fun TIME ctxt producer_enabled name tactic = + if producer_enabled then time_seq ctxt name tactic + else tactic + + fun TIME' ctxt producer_enabled = + if not producer_enabled then K I + else fn msg => fn tactic => TIME ctxt true msg o tactic + + fun TIME_pos ctxt _ producer_enabled name _ = + TIME ctxt producer_enabled name + + fun TIME_pos' ctxt position producer_enabled = + if not producer_enabled then K (K I) + else fn msg => fn logger => fn tactic => + TIME_pos ctxt position true msg logger o tactic + + fun TIME_CB' ctxt position producer_enabled = + if not producer_enabled then K (K (K I)) + else fn msg => fn logger => fn user_callback => fn tactic => + TIME_CB ctxt position true msg logger user_callback o tactic + + (* + `profile_seq` is independent of the sequence element type. It creates one + PIDE stack frame and performs a plain pull. Nested `time` operations resolve + the statically registered PIDE sink against that frame. + *) + fun profile_seq invocation_name ctxt make_sequence = + if not (Config.get ctxt enabled) then + make_sequence ctxt + else + let + val id = serial () + val statistics = + Fine_Grained_Timing_Accumulator.create + ("Fine-grained timing invocation " ^ Value.print_int id) + val invocation = { + id = id, + invocation_name = invocation_name, + position = Position.thread_data (), + statistics = statistics + } + val profiles = PIDE_Profiles.get ctxt + val ctxt' = PIDE_Profiles.put (statistics :: profiles) ctxt + in + Seq.make (fn _ => + let + val output = Seq.pull (make_sequence ctxt') + val _ = emit_pide_report ctxt' invocation (is_some output) + in output end) + end + + fun profile_tactic invocation_name ctxt make_tactic state = + profile_seq invocation_name ctxt + (fn ctxt' => make_tactic ctxt' state) + + (* Methods additionally return proof contexts. Restore the caller's profile + stack in each result while preserving every unrelated context update. *) + fun profile_method invocation_name make_method facts context = + let + val ctxt = fst context + val profiles = PIDE_Profiles.get ctxt + in + profile_seq invocation_name ctxt + (fn ctxt' => make_method ctxt' facts (ctxt', snd context)) + |> Seq.map_result (fn (result_ctxt, result) => + (PIDE_Profiles.put profiles result_ctxt, result)) + end +end; + +(* +The generic Isar wrappers expose the two levels of the timing model: + + apply (profile ‹time "normalization" ‹simp››) + +`profile` creates and finalizes one invocation. Nested `time` methods add +named samples to its PIDE accumulator. A standalone `time` method still +serves the output sink or any custom sink; with no active sink it runs its +embedded method unchanged. + +Both wrappers accept an optional string before the embedded method. For +`profile`, it names the invocation in the report header. For `time`, it names +the sample. Without a string, the embedded method text is used. +*) +local + val parse_message = + Scan.optional (Parse.string >> SOME) NONE + val parse_method = + Parse.embedded_input >> + (fn source => + (Input.string_of source, + fn ctxt => + Method.evaluate + (Method.read_closure_input ctxt source |> fst) ctxt)) + val parser = + Scan.lift (parse_message -- parse_method) >> + (fn (message, (method_name, method)) => + (the_default method_name message, method)) +in + val _ = Theory.setup + (Method.setup @{binding "profile"} + (parser >> (fn (name, method) => fn _ => + Fine_Grained_Timing.profile_method name method)) + "profile a method and emit one bundled fine-grained timing report") + + val _ = Theory.setup + (Method.setup @{binding "time"} + (parser >> (fn (name, method) => fn _ => + Fine_Grained_Timing.time_method name method)) + "record one named sample for all active fine-grained timing sinks") +end; diff --git a/Makefile b/Makefile index 15404a28..32bf0f54 100644 --- a/Makefile +++ b/Makefile @@ -8,8 +8,8 @@ ###################################################################### .DEFAULT_GOAL: jedit -.PHONY: register-afp-components build autolocality-tests \ - autolocality-stress jedit tutorial \ +.PHONY: register-components register-afp-components register-timing-component \ + build autolocality-tests autolocality-stress jedit tutorial \ build-ic2 ic2 ic2-status ic2-stop # Set this to the directory containing the Isabelle2025-2 binary @@ -41,27 +41,32 @@ ISABELLE_JEDIT_FLAGS?= ISABELLE_FLAGS += $(ISABELLE_REMOTE) ISABELLE_JEDIT_FLAGS += $(ISABELLE_REMOTE) -jedit: register-afp-components +jedit: register-components $(ISABELLE_HOME)/isabelle jedit $(ISABELLE_JEDIT_FLAGS) -l HOL -d . ./AutoCorrode.thy & +register-components: register-afp-components register-timing-component + register-afp-components: $(ISABELLE_HOME)/isabelle components -u $(AFP_COMPONENT_BASE)/Word_Lib -build: register-afp-components +register-timing-component: + $(ISABELLE_HOME)/isabelle components -u $(CURDIR)/Fine_Grained_Timing + +build: register-components $(ISABELLE_HOME)/isabelle build $(ISABELLE_FLAGS) -d . \ AutoCorrode AutoLocality_Tests -autolocality-tests: register-afp-components +autolocality-tests: register-components $(ISABELLE_HOME)/isabelle build $(ISABELLE_FLAGS) -d . AutoLocality_Tests # Kept as a compatibility entry point. The unified test session includes # the former locale-retention stress theory. -autolocality-stress: register-afp-components +autolocality-stress: register-components $(ISABELLE_HOME)/isabelle build $(ISABELLE_FLAGS) -d . AutoLocality_Tests # Build the slide-deck tutorial in tutorial/. Inherits the AutoCorrode # parent heap, so run `make build` first if it isn't built yet. -tutorial: register-afp-components +tutorial: register-components $(MAKE) -C tutorial ISABELLE_HOME=$(ISABELLE_HOME) build ####################################### @@ -94,7 +99,7 @@ build-ic2: # Start a daemonised ic2 server for the full AutoCorrode session, on the HOL # heap. Run `make build` first to have the AutoCorrode heap ready; otherwise the # cold build runs in the background (see ic2/README.md). -ic2: register-afp-components build-ic2 +ic2: register-components build-ic2 $(ISABELLE_HOME)/isabelle ic2 server start $(IC2_FLAGS) -n $(IC2_NAME) -d . -l HOL @echo '' @echo ' ic2 server "$(IC2_NAME)" launched. Follow its console (build progress + logs) with:' diff --git a/ROOT b/ROOT index 6e883951..2483070d 100644 --- a/ROOT +++ b/ROOT @@ -9,6 +9,7 @@ session AutoCorrode = HOL + "Crush" "Data_Structures" "Enum_Theory" + "Fine_Grained_Timing" "iq" "Micro_Rust_Examples" "Micro_Rust_Interfaces" diff --git a/ROOTS b/ROOTS index 5dc13fe0..af30f99e 100644 --- a/ROOTS +++ b/ROOTS @@ -3,6 +3,7 @@ Byte_Level_Encoding Crush Data_Structures Enum_Theory +Fine_Grained_Timing iq Lenses_And_Other_Optics Misc From 76b7fbaaaccc92fb5b968ad3adddb66b39a38f95 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:29 +0100 Subject: [PATCH 12/46] Crush: Publish fine-grained timing profiles MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Crush already names and times internal tactic attempts, including attempts that return no result. The measurements depended on `applyτ` and completed histories in proof contexts. Ordinary Crush calls could not publish durable aggregate data. Import the generic timing component and wrap `crush_base`, `fastcrush_base`, and `crush_base_step` with `profile_tactic`. Existing `TIME` wrappers feed active sinks. Low-level callbacks that always need a measurement use `measure_seq`. Remove `applyτ`, its display commands, stored histories, and obsolete examples. Keep the Crush selectors, threshold, and PIDE modifier as producer controls. The wrapper pulls one ordinary lazy-sequence result and does not add an implicit outer total. Signed-off-by: Hanno Becker --- Crush/Base.thy | 8 +- Crush/Examples.thy | 36 +-- Crush/ROOT | 1 + Crush/Separation_Logic_Tactics.thy | 2 +- Crush/crush.ML | 22 +- Crush/seplog.ML | 14 +- Crush/tacticals.ML | 6 +- Crush/time.ML | 414 ------------------------- Micro_Rust_Examples/Crush_Examples.thy | 114 +------ Misc/Simple_Word_Enums.thy | 5 +- 10 files changed, 47 insertions(+), 575 deletions(-) delete mode 100644 Crush/time.ML diff --git a/Crush/Base.thy b/Crush/Base.thy index 7455a26a..a2d5231b 100644 --- a/Crush/Base.thy +++ b/Crush/Base.thy @@ -3,10 +3,9 @@ (*<*) theory Base - imports Main + imports Main "Fine_Grained_Timing.Fine_Grained_Timing" keywords - "enable_print_timings" "disable_print_timings" "enable_timings" "disable_timings" - "reset_timelogs" "show_timelogs" "apply\" "step" :: prf_script % "proof" + "step" :: prf_script % "proof" begin subsection \Configuration\ @@ -24,8 +23,7 @@ ML_file "parsers.ML" subsection \Tactic profiling\ -ML_file "time.ML" -ML\open Crush_Time\ +ML\open Fine_Grained_Timing\ subsection\Meng-Paulson filter for premises\ diff --git a/Crush/Examples.thy b/Crush/Examples.thy index 8341335b..ce706632 100644 --- a/Crush/Examples.thy +++ b/Crush/Examples.thy @@ -1023,38 +1023,4 @@ schematic_goal \?y = ?y\ apply refl_schematic oops -subsubsection\Profiling\ - -lemma - shows \(\x. \y. R x y) \ (\f. \x. R x (f x))\ - show_timelogs (* Nothing showing up *) - apply\(time auto) (* time <> is meaningful without auto\, in which case it only prints - the measurments to the tracing output. apply\ means that the measurements - will be accumulated in the proof context *) - show_timelogs - apply\(time auto) - apply\(time auto) - enable_print_timings - apply\(time auto) - apply\(time auto) - apply\(time "sleep" \sleep 1\) - show_timelogs (* See the update time logs *) - disable_print_timings - apply\(time auto) - apply\(time auto) - reset_timelogs (* Start again *) - apply\(tactic \Crush_Time.TIME @{context} true "auto_tac" (auto_tac @{context})\) - show_timelogs (* Shouldn't show anything *) - apply\(time auto) - apply\(time auto) - apply\(time auto) - apply\(time auto) - show_timelogs (* Logs for the last 4 auto calls *) - (* apply\ unfortunately never fails -- that seems to be necessary so we are allowed - to update the proof context. It would be useful to at least have markup indicating - that the inner method failed, but I don't know how to do that yet. *) - apply\ (time "clssarsimp" \assumption | auto\) - show_timelogs - oops - -end \ No newline at end of file +end diff --git a/Crush/ROOT b/Crush/ROOT index 9f8abf75..f8168acf 100644 --- a/Crush/ROOT +++ b/Crush/ROOT @@ -3,6 +3,7 @@ session Crush = HOL + sessions "HOL-Eisbach" "HOL-Library" + Fine_Grained_Timing Misc Micro_Rust_Parsing_Frontend Micro_Rust_Interfaces_Core diff --git a/Crush/Separation_Logic_Tactics.thy b/Crush/Separation_Logic_Tactics.thy index fb1ce96d..1ada352f 100644 --- a/Crush/Separation_Logic_Tactics.thy +++ b/Crush/Separation_Logic_Tactics.thy @@ -298,7 +298,7 @@ subsection\Crush\ ML_file "crush.ML" ML\open Crush_Tacticals\ -ML\open Crush_Time\ +ML\open Fine_Grained_Timing\ subsection\Arithmetic\ diff --git a/Crush/crush.ML b/Crush/crush.ML index fe4cc499..c43412d8 100644 --- a/Crush/crush.ML +++ b/Crush/crush.ML @@ -799,7 +799,9 @@ struct post_step_tac_parser, additional_tac_parser, additional_method_parser, abort_at_filter_parser, abort_at_pattern_parser] - val time_parsers = [make_time_parser "steps" Crush_Config.time_steps, + val time_parsers = [make_arg_parser' (Args.$$$ "pide" |-- Args.$$$ "timing") + Parser.parse_bool (Config.put Fine_Grained_Timing.enabled) \<^here>, + make_time_parser "steps" Crush_Config.time_steps, make_time_parser "clarsimp" Crush_Config.time_clarsimp, make_time_parser "toplevel" Crush_Config.time_toplevel] val log_parsers = [make_log_parser "toplevel" Crush_Config.log_toplevel, @@ -863,13 +865,25 @@ end; local val _ = Theory.setup (Method.setup @{binding "crush_base"} - (Method.sections Crush.crush_modifiers |-- Scan.succeed (SIMPLE_METHOD o Crush.crush_base_tac)) "") + (Method.sections Crush.crush_modifiers |-- + Scan.succeed (fn ctxt => + SIMPLE_METHOD + (Fine_Grained_Timing.profile_tactic + "crush_base" ctxt Crush.crush_base_tac))) "") val _ = Theory.setup (Method.setup @{binding "fastcrush_base"} - (Method.sections Crush.crush_modifiers |-- Scan.succeed (SIMPLE_METHOD o Crush.fastcrush_base_tac)) "") + (Method.sections Crush.crush_modifiers |-- + Scan.succeed (fn ctxt => + SIMPLE_METHOD + (Fine_Grained_Timing.profile_tactic + "fastcrush_base" ctxt Crush.fastcrush_base_tac))) "") val _ = Theory.setup (Method.setup @{binding "crush_base_step"} (Method.sections Crush.crush_modifiers |-- - Scan.succeed (SIMPLE_METHOD o HEADGOAL o (fn ctxt => Crush.crush_base_step_tac ctxt default_logger))) "") + Scan.succeed (fn ctxt => + SIMPLE_METHOD + (Fine_Grained_Timing.profile_tactic + "crush_base_step" ctxt + (fn ctxt' => HEADGOAL (Crush.crush_base_step_tac ctxt' default_logger))))) "") in end diff --git a/Crush/seplog.ML b/Crush/seplog.ML index f9cb386c..b81c2b8f 100644 --- a/Crush/seplog.ML +++ b/Crush/seplog.ML @@ -1088,7 +1088,7 @@ struct let val ucincl_intro = intro_tac (Named_Theorems.get ctxt @{named_theorems ucincl_intros}) ctxt val ucincl_elim = elim_tac (Named_Theorems.get ctxt @{named_theorems ucincl_elims}) ctxt val ctxt' = ctxt addsimps @{thms Let_def} - fun NOTE msg = Crush_Time.TIME' ctxt (Config.get ctxt Crush_Config.time_ucincl) msg + fun NOTE msg = Fine_Grained_Timing.TIME' ctxt (Config.get ctxt Crush_Config.time_ucincl) msg #> Crush_Tacticals.LOG' ctxt (Config.get ctxt Crush_Config.log_ucincl) msg in Crush_Tacticals.IF' is_ucincl ( NOTE "ucincl_solve" ( ( REPEAT_ALL_NEW ( @@ -2129,7 +2129,7 @@ struct (TRY o (solves_reference_axioms ctxt |> SOLVED'))) val aentails_cancel_points_to_raw_with_typed_tac : Proof.context -> int -> tactic = fn ctxt => let - fun NOTE msg = Crush_Time.TIME' ctxt (Config.get ctxt Crush_Config.time_aentails_cancel) msg + fun NOTE msg = Fine_Grained_Timing.TIME' ctxt (Config.get ctxt Crush_Config.time_aentails_cancel) msg #> Crush_Tacticals.LOG' ctxt (Config.get ctxt Crush_Config.log_aentails_cancel) msg in NOTE "aentails_cancel_raw_with_typed_float_concls" (aentails_float_points_to_concls_tac' ctxt) THEN' NOTE "aentails_cancel_raw_with_typed_float_assms" (aentails_float_points_to_raw_assms_tac' ctxt) @@ -2198,7 +2198,7 @@ struct (* TODO: This is out of sync with the _method_ `aentails_simp_core` *) val aentails_simp_core_tac : Proof.context -> int -> tactic = fn ctxt => let - fun NOTE msg = Crush_Time.TIME' ctxt (Config.get ctxt Crush_Config.time_aentails_core) msg + fun NOTE msg = Fine_Grained_Timing.TIME' ctxt (Config.get ctxt Crush_Config.time_aentails_core) msg #> Crush_Tacticals.LOG' ctxt (Config.get ctxt Crush_Config.log_aentails_core) msg in ucincl_discharge_tac ctxt ( NOTE "aentails_core_hoist_pure_assms" (aentails_hoist_pure_assms_tac ctxt) @@ -2223,7 +2223,7 @@ struct end fun aentails_cancel_core_tac ctxt = - (Crush_Time.TIME' ctxt (Config.get ctxt Crush_Config.time_aentails_cancel) "aentails_cancel_tac_unify_and_float" + (Fine_Grained_Timing.TIME' ctxt (Config.get ctxt Crush_Config.time_aentails_cancel) "aentails_cancel_tac_unify_and_float" (aentails_float_match ctxt (is_cancellable_pair ctxt))) THEN' (resolve_tac ctxt @{thms aentails_refl asepconj_mono asepconj_mono5 aentails_cancel_r}) @@ -2232,7 +2232,7 @@ struct K no_tac else let - fun NOTE msg = Crush_Time.TIME' ctxt (Config.get ctxt Crush_Config.time_aentails_cancel) msg + fun NOTE msg = Fine_Grained_Timing.TIME' ctxt (Config.get ctxt Crush_Config.time_aentails_cancel) msg #> Crush_Tacticals.LOG' ctxt (Config.get ctxt Crush_Config.log_aentails_cancel) msg in NOTE "aentails_cancel_tac_points_to" (aentails_cancel_points_to_tac ctxt) ORELSE' NOTE "aentails_cancel_tac_points_to_raw" (aentails_cancel_points_to_raw_tac ctxt) @@ -2241,7 +2241,7 @@ struct end val aentails_cancel_tac : Proof.context -> int -> tactic = fn ctxt => let - fun NOTE msg = Crush_Time.TIME' ctxt (Config.get ctxt Crush_Config.time_aentails_cancel) msg + fun NOTE msg = Fine_Grained_Timing.TIME' ctxt (Config.get ctxt Crush_Config.time_aentails_cancel) msg #> Crush_Tacticals.LOG' ctxt (Config.get ctxt Crush_Config.log_aentails_cancel) msg in NOTE "aentails_cancel_tac_core" (aentails_cancel_core_tac ctxt) ORELSE' NOTE "aentails_cancel_tac_multi" (aentails_cancel_multi_tac ctxt) @@ -2295,7 +2295,7 @@ struct CONVERSION (aentails_simp_concls_conv thms ctxt) val unfold_prems_tac : thm list -> Proof.context -> int -> tactic = fn thms => fn ctxt => - let val TIME = Crush_Time.TIME' ctxt (Config.get ctxt Crush_Config.time_unfold_prems) in + let val TIME = Fine_Grained_Timing.TIME' ctxt (Config.get ctxt Crush_Config.time_unfold_prems) in CHANGED_PROP o ( TRY o TIME "unfold_prems_sat_unfold" (Crush_Unfold.sat_unfold_tac thms ctxt) (* This seems redundant given the saturating unfold...? diff --git a/Crush/tacticals.ML b/Crush/tacticals.ML index aa872ca6..a9150ab1 100644 --- a/Crush/tacticals.ML +++ b/Crush/tacticals.ML @@ -144,7 +144,7 @@ struct |> Pretty.text_fold |> log else () in - Crush_Time.time_seq cb tac + Fine_Grained_Timing.measure_seq cb tac end end @@ -160,7 +160,7 @@ struct else (msg ^ " fail (" ^ (time |> time_to_str) ^ ")" |> tracing) in - ptac_start THEN Crush_Time.time_seq cb tac THEN ptac_end + ptac_start THEN Fine_Grained_Timing.measure_seq cb tac THEN ptac_end end fun LOG_pos' (ctxt : Proof.context) (pos : Position.T) (enable : bool) : string -> logger -> (int -> tactic) -> (int -> tactic) = @@ -237,7 +237,7 @@ struct (* Fast path: if there are no schematics in the pre-state, the wrapped tactic cannot instantiate any, so skip the observation entirely. *) if null names_before then tac' i st - else Crush_Time.time_seq cb (tac' i) st + else Fine_Grained_Timing.measure_seq cb (tac' i) st end fun LOGFULL' (ctxt : Proof.context) (enable : bool) : string -> (int -> tactic) -> (int -> tactic) = diff --git a/Crush/time.ML b/Crush/time.ML deleted file mode 100644 index b05ba873..00000000 --- a/Crush/time.ML +++ /dev/null @@ -1,414 +0,0 @@ -(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. - SPDX-License-Identifier: MIT *) - -signature CRUSH_TIME = -sig - val TIME : Proof.context -> bool -> string -> tactic -> tactic - val TIME' : Proof.context -> bool -> string -> (int -> tactic) -> (int -> tactic) - - val TIME_pos : Proof.context -> Position.T -> bool -> string -> logger -> tactic -> tactic - val TIME_pos' : Proof.context -> Position.T -> bool -> string -> logger -> (int -> tactic) -> (int -> tactic) - - val TIME_CB : Proof.context -> Position.T -> bool -> string -> logger - -> (thm -> thm option -> Timing.timing -> bool -> unit) - -> tactic -> tactic - val TIME_CB' : Proof.context -> Position.T -> bool -> string -> logger - -> (thm -> thm option -> Timing.timing -> bool -> unit) - -> (int -> tactic) -> (int -> tactic) - - type TimingReport = string * bool * Timing.timing - val report : Proof.context -> TimingReport -> unit - - val time_method : logger -> string -> Position.T -> bool -> Method.method -> Method.method - val time_seq : ('b -> 'a option -> Timing.timing -> bool -> unit) -> ('b -> 'a Seq.seq) -> 'b -> 'a Seq.seq - - val timing_enabled : bool Config.T - val print_timings : bool Config.T - val timing_threshold_us : int Config.T - val hall_of_fame_size : int Config.T - - type TimingSummary - type TimingStatistics - val print_timing_summary : string -> TimingSummary -> unit - val print_timing_statistics : Proof.context -> TimingStatistics -> unit - - val merge_statistics : TimingStatistics -> TimingStatistics -> TimingStatistics - - val get_stored_timing_statistics : Proof.context -> TimingStatistics - - val time_it : (unit -> 'a) -> (unit -> Timing.timing * 'a) - val time_and_report : Proof.context -> string -> bool -> (unit -> 'a) -> 'a - val time_it_with_status : (unit -> 'a) -> ('a -> bool) -> (unit -> (Timing.timing * bool) * 'a) -end; - -structure Crush_Time: CRUSH_TIME = -struct - val timing_enabled = Attrib.setup_config_bool @{binding "crush_timing_enabled"} (K false) - val print_timings = Attrib.setup_config_bool @{binding "crush_print_timings"} (K false) - val timing_threshold_us = Attrib.setup_config_int @{binding "crush_timing_threshold"} (K 2000) - val hall_of_fame_size = Attrib.setup_config_int @{binding "crush_time_hall_of_fame"} (K 100) - - type TimingReport = string * bool * Timing.timing - type IndividualStatistics = { successes: Timing.timing list, failures : Timing.timing list } - type TimingStatistics = IndividualStatistics Symtab.table - val timing_statistics_empty = Symtab.empty - - structure TimingData = Proof_Data ( - type T = { - current_log: TimingStatistics Unsynchronized.ref option, - stored_logs: TimingStatistics - }; - val init = K {current_log = NONE, - stored_logs = timing_statistics_empty}); - - fun merge_timing_lists tl0 tl1 = tl0 @ tl1 - - val merge_success_stats = merge_timing_lists - val merge_failure_stats = merge_timing_lists - - fun add_result_to_individual_statistics success timing {successes = s, failures = f} = - if success then { successes = timing :: s, failures = f } - else { successes = s, failures = timing :: f } - - val empty_individual_statistics = { successes = [], failures = [] } - - fun merge_individual_statistics { successes = s0, failures = f0 } { successes = s1, failures = f1 } = - { successes = merge_success_stats s0 s1, failures = merge_failure_stats f0 f1 } - - fun add_report (t : TimingReport) = - let val (name, success, timing) = t in - (Symtab.default (name, empty_individual_statistics) #> - Symtab.map_entry name (add_result_to_individual_statistics success timing)) - end - - fun int_list_0_to_n n = - let fun core acc n = if n = 0 then acc else core ((n-1) :: acc) (n-1) in - core [] n - end - - type TimingSummary = { samples : int, - total_time : Time.time, - avg_time : Time.time, - median_time : Time.time, - percentiles : Time.time list } - - val timing_summary_empty = { samples = 0, total_time = Time.zeroTime, avg_time = Time.zeroTime, median_time = Time.zeroTime, percentiles = [] } - - val time_to_str = fn t => Time.fmt 6 t ^ "s" - - fun print_timing_summary (title : string) (t : TimingSummary) = - let val timing_percentiles_str = - fold (fn x => fn s => s ^ " " ^ (x |> time_to_str)) (t |> #percentiles) "" in ( - title |> tracing; - " * Number of time reports: " ^ (t |> #samples |> Int.toString) |> tracing; - " * " ^ "total " ^ (t |> #total_time |> time_to_str) ^ ", " - ^ "average " ^ (t |> #avg_time |> time_to_str) ^ ", " - ^ "median " ^ (t |> #median_time |> time_to_str) |> tracing; - " * Percentiles: " ^ timing_percentiles_str |> tracing - ) end - - fun quicksort [] _ = [] - | quicksort (x :: xs) compare_le = - let fun partition x ys compare_le = - let fun core (left, right) [] = (left, right) - | core (left, right) (t :: ts) = - if compare_le (t, x) then - core (t :: left, right) ts - else - core (left, t :: right) ts in - core ([],[]) ys end - val (bot, top) = partition x xs compare_le in - (quicksort bot compare_le) @ [x] @ (quicksort top compare_le) - end - - fun make_timing_summary_core timings = - let val num_timings = List.length timings in - if num_timings = 0 then timing_summary_empty else let - fun compare_elapsed (t0,t1) = Time.<= (#elapsed t0, #elapsed t1) - val timings_sorted = quicksort timings compare_elapsed - val total_time = fold (curry Time.+) (List.map #elapsed timings) Time.zeroTime - val avgtime = (total_time |> Time.toMicroseconds) div num_timings |> Time.fromMicroseconds - fun middle_entry ls = List.nth (ls, (List.length ls) div 2) - fun percentiles xs num = let - val len = List.length xs - val nums = int_list_0_to_n num - val idxs = List.map (fn i => (i * len) div num) nums in - (List.map (fn idx => List.nth (xs, idx)) idxs) @ [List.last xs] - end - val percentile_granularity = 10 - val timing_percentiles = percentiles timings_sorted percentile_granularity - val median_time = middle_entry timings_sorted in - { samples = num_timings, - total_time = total_time, - avg_time = avgtime, - median_time = median_time |> #elapsed, - percentiles = List.map #elapsed timing_percentiles } - end end - - type TimingSummaryToplevel = { name : string, - total_time_all : Time.time, - success_stats : TimingSummary, - failure_stats : TimingSummary } - - fun timing_summary_toplevel_comp ((t0,t1) : TimingSummaryToplevel * TimingSummaryToplevel): bool - = Time.<= (t0 |> #total_time_all, t1 |> #total_time_all) - - fun make_timing_summary (name : string) (stats : IndividualStatistics) : TimingSummaryToplevel = - let val success_stats = make_timing_summary_core (stats |> #successes) - val failure_stats = make_timing_summary_core (stats |> #failures) - val total = (success_stats |> #total_time) + (failure_stats |> #total_time) in - { name = name, - total_time_all = total, - success_stats = success_stats, - failure_stats = failure_stats } - end - - fun print_timing_summary_toplevel (stats : TimingSummaryToplevel) = - ("Timing statistics for: " ^ (stats |> #name) |> tracing; - "- Total time: " ^ (stats |> #total_time_all |> time_to_str) |> tracing; - print_timing_summary "- SUCCESSES" (stats |> #success_stats); - print_timing_summary "- FAILURES" (stats |> #failure_stats)) - - fun print_time_list (ls : (string * Time.time * Time.time * Time.time) list) : unit = - let fun print_time_list_entry (name, total_all, total_success, total_fail): unit = - "- " ^ name ^ ": " ^ ( total_all |> time_to_str) ^ - " (" ^ (total_fail |> time_to_str) ^ " failing, " ^ - (total_success |> time_to_str) ^ " succeeding)" |> tracing in - (List.map print_time_list_entry ls; ()) - end - - fun print_timing_statistics (ctxt : Proof.context) = - let val num = Config.get ctxt hall_of_fame_size in - fn (ts : TimingStatistics) => - let val stats = List.map (uncurry make_timing_summary) (Symtab.dest ts) - val stats = quicksort stats timing_summary_toplevel_comp |> List.rev - val top_time_sinks = List.map (fn s => (s |> #name, - s |> #total_time_all, - s |> #success_stats |> #total_time, - s |> #failure_stats |> #total_time)) stats - |> take num in - ("Top ten time sinks" |> tracing; - print_time_list top_time_sinks; - List.map print_timing_summary_toplevel stats; ()) end end - - val merge_statistics = - Symtab.join (K (uncurry merge_individual_statistics)) |> curry - - fun map_current_log (f : TimingStatistics Unsynchronized.ref option -> - TimingStatistics Unsynchronized.ref option) = - fn {current_log = cl, stored_logs = sl} => {current_log = f cl, stored_logs = sl } - - fun map_stored_logs (f : TimingStatistics -> TimingStatistics) = - fn {current_log = cl, stored_logs = sl} => {current_log = cl, stored_logs = f sl } - - fun print_timing (log : logger) (pos : Position.T) (msg, success, timing) = - let val success_str = if success then "SUCCESS" else "FAIL" in - ([Pretty.mark_str (Markup.properties (Position.properties_of pos) Markup.position, msg), - Pretty.brk 1, Pretty.enclose "(" ")" (success_str |> Pretty.text), Pretty.brk 1, - Pretty.str (Timing.message timing) ]) - |> Pretty.block |> log end - - fun filter_report (ctxt : Proof.context) = - let val threshold = Time.fromMicroseconds (Config.get ctxt timing_threshold_us) - in - fn (_, _, t) : TimingReport => #elapsed t > threshold - end - - fun time_it_with_status (f : unit -> 'a) (is_good: 'a -> bool) : unit -> (Timing.timing * bool) * 'a = - (fn _ => - let val start = Timing.start () - val res = f () - val t = Timing.result start - in - ((t, is_good res), res) - end) - - fun time_it (f : unit -> 'a) : unit -> Timing.timing * 'a = - time_it_with_status f (K true) #> apfst fst - - val get_stored_timing_statistics = TimingData.get #> #stored_logs - - fun timelog_print (ctxt : Proof.context) = - (get_stored_timing_statistics ctxt |> print_timing_statistics ctxt; - ctxt) - - val timelog_start = - (fn x => ( - if is_some x then x else SOME (Unsynchronized.ref Symtab.empty)) - )|> map_current_log |> TimingData.map - - val timelog_end = (fn {current_log = cl, stored_logs = sl} => ( - let val new_log_opt = cl |> Option.map Unsynchronized.! - val sl_new = (case new_log_opt of - SOME new_log => merge_statistics new_log sl - | NONE => sl) in - { current_log = NONE, stored_logs = sl_new } - end)) |> TimingData.map - - val timelog_reset = K timing_statistics_empty |> map_stored_logs |> TimingData.map - - fun report_timing_in_context (ctxt : Proof.context) (p : Position.T) (log : logger) = - let val filter_report = filter_report ctxt - val print_timings = if Config.get ctxt print_timings then print_timing log p else K () - in fn (r : TimingReport) => - if filter_report r then ( - (print_timings r); - let val ptr_opt = ctxt |> TimingData.get |> #current_log in - case ptr_opt of - SOME ptr => ptr := add_report r (Unsynchronized.! ptr ) - | NONE => () - end) else () end - - fun report (ctxt : Proof.context) = report_timing_in_context ctxt Position.none default_logger - - fun time_and_report (ctxt : Proof.context) (msg : string) (enabled : bool) (f : unit -> 'a) = - if enabled then - let - val (time, result) = time_it f () - val _ = report ctxt (msg, true (* success *), time) - in result end - else - f () - - fun time_seq (cb : 'b -> 'a option -> Timing.timing -> bool -> unit) (s : 'b -> 'a Seq.seq): 'b -> 'a Seq.seq = - fn b => Seq.make (fn _ => - let val ((timing, status), output) = time_it_with_status (fn _ => Seq.pull (s b)) is_some () - val _ = cb b (Option.map fst output) timing status in - output end) - - fun time_method (log : logger) (msg: string) (p : Position.T) (force : bool) (method: Method.method) : Method.method = - (fn thms => fn ctxt => - if force orelse Config.get (fst ctxt) timing_enabled then - let fun cb _ _ timing success = ( - let val r = (msg, success, timing) - val _ = if force then print_timing log p r else () in - report_timing_in_context (fst ctxt) p log r - end) in - time_seq cb (method thms) ctxt - end - else - method thms ctxt - ) - - val TIME_CB : Proof.context -> Position.T -> bool -> string -> logger - -> (thm -> thm option -> Timing.timing -> bool -> unit) -> tactic -> tactic = - fn ctxt => fn p => let val report = report_timing_in_context ctxt p - val timing_enabled = Config.get ctxt timing_enabled in - fn enabled => if not enabled then K (K (K I)) else fn msg => fn log => fn cb_user => fn t => fn thm => - let fun cb v out timing success = (cb_user v out timing success; - if timing_enabled then report log (msg, success, timing) else ()) - in time_seq cb t thm end - end - - val TIME : Proof.context -> bool -> string -> tactic -> tactic = - fn ctxt => fn enabled => - if enabled andalso Config.get ctxt timing_enabled then - fn msg => TIME_CB ctxt Position.none true msg default_logger - (K (K (K (K ())))) - else - K I - - val TIME' : Proof.context -> bool -> string -> (int -> tactic) -> (int -> tactic) = - fn ctxt => fn enabled => - if enabled andalso Config.get ctxt timing_enabled then - fn msg => fn t => TIME_CB ctxt Position.none true msg default_logger - (K (K (K (K ())))) o t - else - K I - - val TIME_pos : Proof.context -> Position.T -> bool -> string -> logger -> tactic -> tactic = - fn ctxt => fn pos => fn enabled => - if enabled andalso Config.get ctxt timing_enabled then - fn msg => fn log => TIME_CB ctxt pos true msg log - (K (K (K (K ())))) - else - K (K I) - - val TIME_pos' : Proof.context -> Position.T -> bool -> string -> logger -> (int -> tactic) -> (int -> tactic) = - fn ctxt => fn pos => fn enabled => - if enabled andalso Config.get ctxt timing_enabled then - fn msg => fn log => fn t => TIME_CB ctxt pos true msg log - (K (K (K (K ())))) o t - else - K (K I) - - fun TIME_CB' (ctxt: Proof.context) (pos: Position.T) (enabled: bool) : - string - -> logger - -> (thm -> thm option -> Timing.timing -> bool -> unit) - -> (int -> tactic) - -> (int -> tactic) = - if not enabled then K (K (K I)) else fn msg => fn log => fn user_cb => fn t => - TIME_CB ctxt pos true msg log user_cb o t - -val timelog_start'' = - (timelog_start #> (Config.put timing_enabled true)) - |> Proof.map_contexts #> Seq.single - -fun timelog_end'' keep_timings_enabled = - let val restore_timing = - if keep_timings_enabled then I else Config.put timing_enabled false in - (timelog_end #> restore_timing) |> Proof.map_contexts #> Seq.single - end - -val timelogs_reset' = timelog_reset |> Proof.map_contexts #> Seq.Result #> Seq.single -val timelogs_print' = timelog_print |> Proof.map_contexts #> Seq.Result #> Seq.single - -val disable_print_timings' = Config.put timing_enabled false |> Proof.map_contexts #> Seq.Result #> Seq.single -val enable_print_timings' = Config.put timing_enabled true |> Proof.map_contexts #> Seq.Result #> Seq.single - -val disable_timings' = Config.put timing_enabled false |> Proof.map_contexts #> Seq.Result #> Seq.single -val enable_timings' = Config.put timing_enabled true |> Proof.map_contexts #> Seq.Result #> Seq.single - -val _ = - Outer_Syntax.command \<^command_keyword>\show_timelogs\ "print timing report log" - (Scan.succeed (timelogs_print' |> Toplevel.proofs)) - -val _ = - Outer_Syntax.command \<^command_keyword>\reset_timelogs\ "reset timing report log" - (Scan.succeed (timelogs_reset' |> Toplevel.proofs)) - -val _ = - Outer_Syntax.command \<^command_keyword>\disable_print_timings\ "disable printing of time logs" - (Scan.succeed (disable_print_timings' |> Toplevel.proofs)) - -val _ = - Outer_Syntax.command \<^command_keyword>\enable_print_timings\ "enable printing of time logs" - (Scan.succeed (enable_print_timings' |> Toplevel.proofs)) - -val _ = - Outer_Syntax.command \<^command_keyword>\disable_timings\ "disable time logs" - (Scan.succeed (disable_timings' |> Toplevel.proofs)) - -val _ = - Outer_Syntax.command \<^command_keyword>\enable_timings\ "enable time logs" - (Scan.succeed (enable_timings' |> Toplevel.proofs)) - -val _ = - Outer_Syntax.command \<^command_keyword>\apply\\ "apply a method and create timing log for it" - (Method.parse >> (fn m => (Method.report m; Toplevel.proofs (fn ctxt => - let val m_seq = (Proof.apply m) #> Seq.filter_results - val timings_enabled = Config.get (ctxt |> Proof.context_of) timing_enabled in - ( - Seq.THEN (timelog_start'', - Seq.THEN ((Seq.TRY m_seq), (* XXX Figure out how to retain the failure markup here *) - timelog_end'' timings_enabled)) - ) ctxt |> Seq.make_results - end - )))) - - - local - val time_parser_opt_force : bool parser = Scan.optional (Args.$$$ "force" >> K true) false - val time_parser_opt_msg : string option parser = Scan.optional (Parse.string >> SOME) NONE - val time_parser : (Proof.context -> Method.method) context_parser = - Scan.lift ( - (time_parser_opt_force -- time_parser_opt_msg -- Parser.parse_method_with_name) - >> (fn ((force, msg), (method_str, method)) => fn (ctxt : Proof.context) => - time_method default_logger (Option.getOpt (msg,method_str)) Position.none force (method ctxt)) - ) - in - val _ = Theory.setup (Method.setup @{binding "time"} time_parser "") - end - -end; diff --git a/Micro_Rust_Examples/Crush_Examples.thy b/Micro_Rust_Examples/Crush_Examples.thy index 21d8eca6..5674c677 100644 --- a/Micro_Rust_Examples/Crush_Examples.thy +++ b/Micro_Rust_Examples/Crush_Examples.thy @@ -798,11 +798,10 @@ end subsubsection\Profiling \<^verbatim>\crush\\ text\Despite all efforts to keep \<^verbatim>\crush\ fast, some \<^verbatim>\crush\ invocations can take a long time. -In this case, the general profiling variant \<^verbatim>\apply\\ can be used in conjunction with some or all -of the configuration options \<^verbatim>\crush_time_...\ to get a timing profile for \<^verbatim>\crush\. - -NB: Unfortunately, timing profiles are proof local, so you cannot currently aggregate performance -statistics along multiple proofs.\ +The \<^verbatim>\pide timing: true\ modifier emits one bounded PIDE report for the complete +invocation. The report retains successful and failing branch statistics and can be aggregated +by the \<^verbatim>\Fine-Grained Timing\ jEdit panel at command, proof, theory, and global scope. +Global scope combines all timing reports in the current PIDE document session.\ experiment fixes P Q :: \'a \ 's::sepalg assert\ @@ -816,100 +815,9 @@ begin lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ \\By default, the timing mechanism ignores runtimes < 2ms, which is too high to observe the runtime of the tactics in this trivial example. We reduce the threshold to 5ns.\ - using [[crush_time_toplevel, crush_timing_threshold=5]] - apply\ (crush_base simp prems add: Some_Ex_def seplog rule add: PQ) - show_timelogs -(* Top ten time sinks -- crush_branch_aentails_core_tac: 0.000374s (0.000073s failing, 0.000301s succeeding) -- crush_branch_aentails_cancel_tac: 0.000301s (0.000118s failing, 0.000183s succeeding) -- crush_branch_base_simps_tac: 0.000261s (0.000250s failing, 0.000011s succeeding) -- crush_branch_aentails_rule_tac: 0.000079s (0.000000s failing, 0.000079s succeeding) -- crush_branch_unfold_prems_tac: 0.000041s (0.000028s failing, 0.000013s succeeding) -- crush_branch_focus_tac: 0.000026s (0.000026s failing, 0.000000s succeeding) -- crush_branch_schematics_tac: 0.000022s (0.000000s failing, 0.000022s succeeding) -- crush_branch_unfold_concls_tac: 0.000017s (0.000017s failing, 0.000000s succeeding) -Timing statistics for: crush_branch_aentails_core_tac -- Total time: 0.000374s -- SUCCESSES - * Number of time reports: 1 - * total 0.000301s, average 0.000301s, median 0.000301s - * Percentiles: 0.000301s 0.000301s 0.000301s 0.000301s 0.000301s 0.000301s ... -- FAILURES - * Number of time reports: 2 - * total 0.000073s, average 0.000036s, median 0.000039s - * Percentiles: 0.000034s 0.000034s 0.000034s 0.000034s 0.000034s 0.000039s ... -Timing statistics for: crush_branch_aentails_cancel_tac -- Total time: 0.000301s -- SUCCESSES - * Number of time reports: 3 - * total 0.000183s, average 0.000061s, median 0.000064s - * Percentiles: 0.000044s 0.000044s 0.000044s 0.000044s 0.000064s 0.000064s ... -- FAILURES - * Number of time reports: 4 - * total 0.000118s, average 0.000029s, median 0.000047s - * Percentiles: 0.000006s 0.000006s 0.000006s 0.000007s 0.000007s 0.000047s ... -Timing statistics for: crush_branch_base_simps_tac -- Total time: 0.000261s -- SUCCESSES - * Number of time reports: 1 - * total 0.000011s, average 0.000011s, median 0.000011s - * Percentiles: 0.000011s 0.000011s 0.000011s 0.000011s 0.000011s 0.000011s ... -- FAILURES - * Number of time reports: 7 - * total 0.000250s, average 0.000035s, median 0.000038s - * Percentiles: 0.000026s 0.000026s 0.000027s 0.000031s 0.000031s 0.000038s ... -Timing statistics for: crush_branch_aentails_rule_tac -- Total time: 0.000079s -- SUCCESSES - * Number of time reports: 1 - * total 0.000079s, average 0.000079s, median 0.000079s - * Percentiles: 0.000079s 0.000079s 0.000079s 0.000079s 0.000079s 0.000079s ... -- FAILURES - * Number of time reports: 0 - * total 0.000000s, average 0.000000s, median 0.000000s - * Percentiles: -Timing statistics for: crush_branch_unfold_prems_tac -- Total time: 0.000041s -- SUCCESSES - * Number of time reports: 1 - * total 0.000013s, average 0.000013s, median 0.000013s - * Percentiles: 0.000013s 0.000013s 0.000013s 0.000013s 0.000013s 0.000013s ... -- FAILURES - * Number of time reports: 3 - * total 0.000028s, average 0.000009s, median 0.000010s - * Percentiles: 0.000006s 0.000006s 0.000006s 0.000006s 0.000010s 0.000010s ... -Timing statistics for: crush_branch_focus_tac -- Total time: 0.000026s -- SUCCESSES - * Number of time reports: 0 - * total 0.000000s, average 0.000000s, median 0.000000s - * Percentiles: -- FAILURES - * Number of time reports: 1 - * total 0.000026s, average 0.000026s, median 0.000026s - * Percentiles: 0.000026s 0.000026s 0.000026s 0.000026s 0.000026s 0.000026s ... -Timing statistics for: crush_branch_schematics_tac -- Total time: 0.000022s -- SUCCESSES - * Number of time reports: 1 - * total 0.000022s, average 0.000022s, median 0.000022s - * Percentiles: 0.000022s 0.000022s 0.000022s 0.000022s 0.000022s 0.000022s ... -- FAILURES - * Number of time reports: 0 - * total 0.000000s, average 0.000000s, median 0.000000s - * Percentiles: -Timing statistics for: crush_branch_unfold_concls_tac -- Total time: 0.000017s -- SUCCESSES - * Number of time reports: 0 - * total 0.000000s, average 0.000000s, median 0.000000s - * Percentiles: -- FAILURES - * Number of time reports: 1 - * total 0.000017s, average 0.000017s, median 0.000017s - * Percentiles: 0.000017s 0.000017s 0.000017s 0.000017s 0.000017s 0.000017s ... -Top ten time sinks *) - done + using [[crush_time_toplevel, fine_grained_timing_threshold=5]] + apply (crush_base pide timing: true simp prems add: Some_Ex_def seplog rule add: PQ) + done end text\If you suspect that poor performance of \<^verbatim>\crush\ is due to a particular branch running slowly, @@ -1440,9 +1348,8 @@ lemma test_record2_zeroize_contract_spec: shows \\; test_record2_zeroize ptr \\<^sub>F test_record2_zeroize_contract ptr g v\ apply (crush_boot f: test_record2_zeroize_def contract: test_record2_zeroize_contract_def) using [[crush_time_steps, crush_time_base_simps]] - apply\ (crush_base stepwise) + apply (crush_base stepwise) step * - show_timelogs done text\Another similar stress test, but this time using array accesses behind a function wrapper.\ @@ -1585,7 +1492,7 @@ proof (crush_boot f: test_record3_zeroize_def contract: test_record3_zeroize_con note eq = this[simplified] show ?case \\TODO: This proof gets slower over time. Investigate\ - apply\ (crush_base stepwise) + apply (crush_base stepwise) step 100 step 100 step 100 @@ -1595,11 +1502,10 @@ proof (crush_boot f: test_record3_zeroize_def contract: test_record3_zeroize_con step 100 step 100 step * - show_timelogs apply (simp add: eq) done qed end -end \ No newline at end of file +end diff --git a/Misc/Simple_Word_Enums.thy b/Misc/Simple_Word_Enums.thy index 65172337..12779253 100644 --- a/Misc/Simple_Word_Enums.thy +++ b/Misc/Simple_Word_Enums.thy @@ -310,8 +310,9 @@ sig its elapsed time under a name; the accumulated log is printed as a breakdown when timing is on. The timer is carried explicitly (in enum_info) rather than through global state, so a plugin records into the same log the command prints, and parallel runs stay - independent. Modelled on Crush's Crush_Time (Crush/time.ML), pared down: the phases run - once each, so per-name statistics/percentiles are unnecessary here. *) + independent. Unlike the general fine-grained timing support, this timer is deliberately + pared down: the phases run once each, so per-name statistics and percentiles are + unnecessary here. *) type timer (* Timing is off unless this config is set, so a bare declaration is silent as before. *) From 43a13e23a0355bc1a3d9b6f7c3196734a365db35 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:29 +0100 Subject: [PATCH 13/46] I/P: Inspect fine-grained PIDE timings Fine-grained timing reports are stored in compressed PIDE markup exports. `heap-db-inspect` reads only whole-command timings, leaving batch profiling data unavailable outside jEdit. Decode schema versions 1 and 2, including Isabelle XML element and body transports. Add aggregate and per-invocation views, source grouping, separate invocation and sample filters, and versioned JSON that keeps integer microseconds and histogram buckets. Count malformed, unsupported, and duplicate records instead of dropping them silently. Fall back to the `zstd` executable when the Python module is unavailable. Test both schemas, nested markup, deduplication, merging, percentiles, malformed input, and JSON output. Signed-off-by: Hanno Becker --- ip/README.md | 26 +++ ip/fine_timing.py | 378 +++++++++++++++++++++++++++++++ ip/heap-db-inspect | 489 ++++++++++++++++++++++++++++++++++++++++- ip/test_fine_timing.py | 193 ++++++++++++++++ ir/heap_info.py | 14 +- 5 files changed, 1088 insertions(+), 12 deletions(-) create mode 100644 ip/fine_timing.py create mode 100644 ip/test_fine_timing.py diff --git a/ip/README.md b/ip/README.md index a9e82e34..fe612e05 100644 --- a/ip/README.md +++ b/ip/README.md @@ -245,6 +245,32 @@ To help this, two scripts are provided: Only timings recorded by Isabelle are included. +Fine-grained timing reports emitted through PIDE can be inspected separately: + +``` +./heap-db-inspect /path/to/log/SESSION.db --fine-timings +./heap-db-inspect /path/to/log/SESSION.db --fine-timings \ + --fine-view calls --fine-method 'my_method' +./heap-db-inspect /path/to/log/SESSION.db --fine-timings \ + --fine-group-by theory --fine-sample 'normalization|rewrite' +./heap-db-inspect /path/to/log/SESSION.db --fine-timings \ + --format json +``` + +The default view merges samples globally by name and outcome. Aggregates can +instead be grouped by theory, proof, or command. Invocation and sample outcomes +have separate filters because a successful invocation may contain failed inner +attempts. + +Text output shows histogram-derived percentiles with a `≤` suffix: they are +bucket upper bounds rather than exact observations. JSON keeps times as integer +microseconds and includes the histogram so downstream tools can merge reports +without losing percentile information. + +The inspector reads timing messages from `PIDE/markup` exports. Thus the +database must come from a build that enabled fine-grained PIDE timing. A heap +database built without that option is valid but reports zero timing messages. + ### TL;DR * Add the following to your local `etc/settings` (e.g. `~/.isabelle/Isabelle2025-2/etc/settings`): diff --git a/ip/fine_timing.py b/ip/fine_timing.py new file mode 100644 index 00000000..555b70a0 --- /dev/null +++ b/ip/fine_timing.py @@ -0,0 +1,378 @@ +"""Decode and aggregate fine-grained timing reports from PIDE exports.""" + +from dataclasses import dataclass, field +import math + + +X = "\x05" +Y = "\x06" +REPORT_MARKUP = "fine_grained_timing" +ENTRY_MARKUP = "fine_grained_timing_entry" +BUCKET_MARKUP = "fine_grained_timing_bucket" +SUPPORTED_VERSIONS = (1, 2) + + +@dataclass +class YXMLNode: + name: str + properties: dict + body: list = field(default_factory=list) + + +@dataclass +class Timing: + elapsed_us: int + cpu_us: int + gc_us: int + + +@dataclass +class Aggregate: + count: int + timing: Timing + min_elapsed_us: int + max_elapsed_us: int + histogram: dict + + +@dataclass +class Sample: + name: str + success: bool + aggregate: Aggregate + + +@dataclass +class Invocation: + version: int + invocation: int + method: str + success: bool + timing: object + samples: list + theory: str = "" + export_name: str = "" + command: str = "" + command_offset: object = None + source_file: str = "" + line: object = None + proof: str = "" + + +@dataclass +class DecodeResult: + invocations: list = field(default_factory=list) + malformed: int = 0 + unsupported: int = 0 + duplicates: int = 0 + + +class YXMLError(ValueError): + pass + + +class ReportError(ValueError): + pass + + +class UnsupportedVersion(ReportError): + pass + + +def parse_yxml(text): + """Parse a YXML body into text strings and ``YXMLNode`` values.""" + roots = [] + stack = [roots] + for chunk in text.split(X): + if chunk.startswith(Y): + fields = chunk[1:].split(Y) + if fields == [""]: + if len(stack) == 1: + raise YXMLError("unbalanced element close") + stack.pop() + else: + name = fields[0] + if not name: + raise YXMLError("empty element name") + properties = {} + for item in fields[1:]: + if "=" not in item: + raise YXMLError("malformed element property") + key, value = item.split("=", 1) + if not key or key in properties: + raise YXMLError("invalid element property") + properties[key] = value + node = YXMLNode(name, properties) + stack[-1].append(node) + stack.append(node.body) + elif chunk: + stack[-1].append(chunk) + if len(stack) != 1: + raise YXMLError("unclosed element") + return roots + + +def _nodes(body): + return [item for item in body if isinstance(item, YXMLNode)] + + +def _property(properties, name): + if name not in properties: + raise ReportError(f"missing property {name}") + return properties[name] + + +def _integer(properties, name, minimum=None): + text = _property(properties, name) + try: + value = int(text) + except ValueError as ex: + raise ReportError(f"invalid integer property {name}") from ex + if minimum is not None and value < minimum: + raise ReportError(f"property {name} is below {minimum}") + return value + + +def _boolean(properties, name): + value = _property(properties, name) + if value == "true": + return True + if value == "false": + return False + raise ReportError(f"invalid boolean property {name}") + + +def _timing(properties): + return Timing( + elapsed_us=_integer(properties, "elapsed_us"), + cpu_us=_integer(properties, "cpu_us"), + gc_us=_integer(properties, "gc_us"), + ) + + +def _decode_sample(node): + if node.name != ENTRY_MARKUP: + raise ReportError(f"unexpected report body element {node.name}") + properties = node.properties + count = _integer(properties, "count", 1) + histogram = {} + for bucket_node in _nodes(node.body): + if bucket_node.name != BUCKET_MARKUP or _nodes(bucket_node.body): + raise ReportError("malformed histogram bucket") + bucket = _integer(bucket_node.properties, "bucket", 0) + bucket_count = _integer(bucket_node.properties, "count", 1) + if bucket in histogram: + raise ReportError("duplicate histogram bucket") + histogram[bucket] = bucket_count + if sum(histogram.values()) != count: + raise ReportError("histogram count does not match sample count") + timing = _timing(properties) + minimum = _integer(properties, "min_elapsed_us") + maximum = _integer(properties, "max_elapsed_us") + return Sample( + name=_property(properties, "name"), + success=_boolean(properties, "success"), + aggregate=Aggregate( + count=count, + timing=timing, + min_elapsed_us=minimum, + max_elapsed_us=maximum, + histogram=histogram, + ), + ) + + +def _normalize_report_body(body): + nodes = _nodes(body) + if len(body) == 1 and isinstance(body[0], str) and X in body[0]: + return parse_yxml(body[0]) + return nodes + + +def decode_report(properties, body): + version = _integer(properties, "version") + if version not in SUPPORTED_VERSIONS: + raise UnsupportedVersion(f"unsupported report version {version}") + timing = _timing(properties) if version == 1 else None + return Invocation( + version=version, + invocation=_integer(properties, "invocation"), + method=_property(properties, "method"), + success=_boolean(properties, "success"), + timing=timing, + samples=[ + _decode_sample(node) for node in _normalize_report_body(body) + ], + ) + + +def _command_location(ancestors): + for node in reversed(ancestors): + if node.name != "command_span": + continue + command = node.properties.get("name", "") + stack = list(reversed(_nodes(node.body))) + while stack: + child = stack.pop() + offset = child.properties.get("command_offset") + if offset is not None: + try: + return command, int(offset) + except ValueError: + return command, None + stack.extend(reversed(_nodes(child.body))) + return command, None + return "", None + + +def _walk(body, ancestors=()): + stack = [ + (item, ancestors) for item in reversed(body) + if isinstance(item, YXMLNode) + ] + while stack: + item, parents = stack.pop() + yield item, parents + child_parents = parents + (item,) + stack.extend( + (child, child_parents) for child in reversed(item.body) + if isinstance(child, YXMLNode) + ) + + +def extract_reports(text, theory="", export_name=""): + """Decode all transported timing reports in one PIDE markup export.""" + result = DecodeResult() + try: + body = parse_yxml(text) + except YXMLError: + result.malformed += 1 + return result + + seen = set() + for node, ancestors in _walk(body): + properties = None + report_body = None + if (node.name == "xml_elem" and + node.properties.get("xml_name") == REPORT_MARKUP): + properties = { + key: value for key, value in node.properties.items() + if key != "xml_name" + } + bodies = [ + child for child in _nodes(node.body) + if child.name == "xml_body" + ] + if len(bodies) != 1: + result.malformed += 1 + continue + report_body = bodies[0].body + elif node.name == REPORT_MARKUP: + direct = _normalize_report_body(node.body) + if all(isinstance(child, YXMLNode) and + child.name == ENTRY_MARKUP for child in direct): + properties = node.properties + report_body = direct + if properties is None: + continue + + try: + invocation = decode_report(properties, report_body) + except UnsupportedVersion: + result.unsupported += 1 + continue + except (ReportError, YXMLError): + result.malformed += 1 + continue + + invocation.theory = theory + invocation.export_name = export_name + invocation.command, invocation.command_offset = _command_location( + ancestors) + key = ( + theory, invocation.invocation, invocation.method, + invocation.success, invocation.command_offset, + tuple( + (sample.name, sample.success, sample.aggregate.count, + sample.aggregate.timing.elapsed_us, + sample.aggregate.timing.cpu_us, + sample.aggregate.timing.gc_us, + sample.aggregate.min_elapsed_us, + sample.aggregate.max_elapsed_us, + tuple(sorted(sample.aggregate.histogram.items()))) + for sample in invocation.samples + ), + ) + if key in seen: + result.duplicates += 1 + else: + seen.add(key) + result.invocations.append(invocation) + return result + + +def merge_aggregate(left, right): + histogram = dict(left.histogram) + for bucket, count in right.histogram.items(): + histogram[bucket] = histogram.get(bucket, 0) + count + return Aggregate( + count=left.count + right.count, + timing=Timing( + elapsed_us=left.timing.elapsed_us + right.timing.elapsed_us, + cpu_us=left.timing.cpu_us + right.timing.cpu_us, + gc_us=left.timing.gc_us + right.timing.gc_us, + ), + min_elapsed_us=min(left.min_elapsed_us, right.min_elapsed_us), + max_elapsed_us=max(left.max_elapsed_us, right.max_elapsed_us), + histogram=histogram, + ) + + +def percentile_upper_bound(aggregate, fraction): + if aggregate.count <= 0 or not aggregate.histogram: + return 0 + target = max(1, math.ceil(max(0.0, min(1.0, fraction)) * + aggregate.count)) + accumulated = 0 + selected = max(aggregate.histogram) + for bucket, count in sorted(aggregate.histogram.items()): + accumulated += count + if accumulated >= target: + selected = bucket + break + return (1 << (selected + 1)) - 1 if selected < 62 else (1 << 63) - 1 + + +def aggregate_invocations(invocations, group_key): + rows = {} + for invocation in invocations: + group = group_key(invocation) + for sample in invocation.samples: + key = (group, sample.name, sample.success) + if key in rows: + rows[key] = merge_aggregate(rows[key], sample.aggregate) + else: + rows[key] = sample.aggregate + return rows + + +def aggregate_to_json(aggregate): + return { + "count": aggregate.count, + "timing_us": { + "elapsed": aggregate.timing.elapsed_us, + "cpu": aggregate.timing.cpu_us, + "gc": aggregate.timing.gc_us, + "min_elapsed": aggregate.min_elapsed_us, + "max_elapsed": aggregate.max_elapsed_us, + }, + "percentile_upper_bound_us": { + "p50": percentile_upper_bound(aggregate, 0.50), + "p90": percentile_upper_bound(aggregate, 0.90), + "p99": percentile_upper_bound(aggregate, 0.99), + }, + "histogram": { + str(bucket): count + for bucket, count in sorted(aggregate.histogram.items()) + }, + } diff --git a/ip/heap-db-inspect b/ip/heap-db-inspect index 46c8dc31..d99d8d4f 100755 --- a/ip/heap-db-inspect +++ b/ip/heap-db-inspect @@ -15,6 +15,7 @@ Sections (default: -baES): -d, --documents Documents (PDFs) -c, --checksums Sources shasum (rebuild-check digests) -T, --timings Slowest commands and per-file timing + -F, --fine-timings Fine-grained PIDE timing reports -M, --ml-stats ML runtime statistics summary (peak heap, GC, workers) -A, --all Everything @@ -24,16 +25,28 @@ Filters: --top N Number of entries for timing lists (default: 15) --timing-range SPEC Sum commands starting in FILE:START-END --annotate-source SPEC Show source commands, timings, and inferred depths + +Fine-grained timing: + --fine-view VIEW aggregate (default) or calls + --fine-group-by SCOPE global (default), theory, proof, or command + --fine-method REGEX Restrict invocation labels + --fine-sample REGEX Restrict sample labels + --format FORMAT text (default) or json """ import argparse import glob +import json import os import re import shutil import sqlite3 import sys +from fine_timing import ( + DecodeResult, aggregate_invocations, aggregate_to_json, + extract_reports, percentile_upper_bound, +) from isar_source import THY_GOALS, collect_keyword_kinds, infer_commands # Import shared utilities from ir/heap_info.py @@ -830,6 +843,380 @@ def show_timings(conn, session, top_n, theory=None, checker=None, f"{DIM}{short}{RESET}") +def read_fine_timing_reports(conn, session, theory=None): + query = ( + "SELECT theory_name, name, body FROM isabelle_exports " + "WHERE session_name=? AND name LIKE 'PIDE/markup%'") + parameters = [session] + if theory: + query += " AND theory_name=?" + parameters.append(theory) + query += " ORDER BY theory_name, name" + + result = DecodeResult() + seen = set() + missing_decoder = False + for theory_name, export_name, blob in conn.execute(query, parameters): + text = decompress_blob(blob) + if text is None: + missing_decoder = True + continue + decoded = extract_reports(text, theory_name, export_name) + result.malformed += decoded.malformed + result.unsupported += decoded.unsupported + result.duplicates += decoded.duplicates + for invocation in decoded.invocations: + key = ( + invocation.theory, invocation.invocation, invocation.method, + invocation.success, invocation.command_offset, + tuple( + (sample.name, sample.success, sample.aggregate.count, + sample.aggregate.timing.elapsed_us, + sample.aggregate.timing.cpu_us, + sample.aggregate.timing.gc_us, + sample.aggregate.min_elapsed_us, + sample.aggregate.max_elapsed_us, + tuple(sorted(sample.aggregate.histogram.items()))) + for sample in invocation.samples + ), + ) + if key in seen: + result.duplicates += 1 + else: + seen.add(key) + result.invocations.append(invocation) + return result, missing_decoder + + +def _theory_source(checker, theory): + suffix = theory.replace(".", "/") + ".thy" + matches = [ + (name, digest) for name, digest in checker.rows + if name.replace("\\", "/").endswith("/" + suffix) + or name.replace("\\", "/") == suffix + ] + return matches[0] if len(matches) == 1 else (None, None) + + +def _proof_labels(source, commands): + labels = {} + active = None + for command in commands: + if (active is None and command["pre_depth"] == 0 and + command.get("category") in THY_GOALS): + text = command_source_text(source, command) + active = (text.splitlines() or [command["name"]])[0].strip() + if len(active) > 100: + active = active[:97] + "..." + if active is not None: + labels[command["offset"]] = active + if command["post_depth"] == 0: + active = None + return labels + + +def annotate_fine_timing_locations( + invocations, checker, session, isabelle, need_proofs=False): + by_theory = {} + for invocation in invocations: + by_theory.setdefault(invocation.theory, []).append(invocation) + + unavailable = set() + keyword_kinds = None + for theory, theory_invocations in by_theory.items(): + stored, digest = _theory_source(checker, theory) + if stored is None: + unavailable.add(theory) + continue + local_path, matches = checker.check(stored, digest) + if not local_path or matches is not True: + unavailable.add(theory) + continue + for invocation in theory_invocations: + invocation.source_file = stored + if invocation.command_offset is not None: + invocation.line = checker.get_line( + stored, invocation.command_offset) + if not need_proofs: + continue + if keyword_kinds is None: + keyword_kinds = collect_keyword_kinds( + source_keyword_roots(local_path, session, isabelle)) + try: + with open(local_path, "r", errors="replace") as stream: + source = stream.read() + except OSError: + unavailable.add(theory) + continue + timed_commands = { + (invocation.command_offset, invocation.command) + for invocation in theory_invocations + if invocation.command_offset is not None and invocation.command + } + _, commands = infer_commands(source, keyword_kinds, timed_commands) + labels = _proof_labels(source, commands) + for invocation in theory_invocations: + invocation.proof = labels.get(invocation.command_offset, "") + return unavailable + + +def _compile_filter(pattern, option): + try: + return re.compile(pattern, re.IGNORECASE) if pattern else None + except re.error as ex: + raise ValueError(f"Invalid {option} regular expression: {ex}") from ex + + +def filter_fine_timing_invocations(invocations, args): + method = _compile_filter(args.fine_method, "--fine-method") + sample_name = _compile_filter(args.fine_sample, "--fine-sample") + grep = _compile_filter(args.grep, "--grep") + selected = [] + for invocation in invocations: + if (args.fine_invocation_outcome != "all" and + invocation.success != + (args.fine_invocation_outcome == "success")): + continue + if method and not method.search(invocation.method): + continue + grep_matches_invocation = ( + not grep or grep.search(invocation.theory) or + grep.search(invocation.method)) + samples = [] + for sample in invocation.samples: + if (args.fine_sample_outcome != "all" and + sample.success != + (args.fine_sample_outcome == "success")): + continue + if sample_name and not sample_name.search(sample.name): + continue + if (grep and not grep_matches_invocation and + not grep.search(sample.name)): + continue + samples.append(sample) + sample_filtering = ( + sample_name is not None or + args.fine_sample_outcome != "all") + if samples or ( + not invocation.samples and not sample_filtering and + grep_matches_invocation): + invocation.samples = samples + selected.append(invocation) + return selected + + +def _fine_group(invocation, group_by): + if group_by == "global": + return "" + if group_by == "theory": + return invocation.theory + location = invocation.theory + if invocation.line is not None: + location += f":{invocation.line}" + elif invocation.command_offset is not None: + location += f"+{invocation.command_offset}" + if group_by == "command": + return f"{location} {invocation.command}".rstrip() + return f"{location} {invocation.proof or '(unknown proof)'}" + + +def _fmt_micros(value): + if value >= 1_000_000: + return f"{value / 1_000_000:.3f}s" + if value >= 1_000: + return f"{value / 1_000:.3f}ms" + return f"{value}us" + + +def _display_fine_group(group, group_by, width=56): + display = group + if group_by in ("proof", "command"): + colon = group.find(":") + if colon >= 0: + dot = group.rfind(".", 0, colon) + if dot >= 0: + display = group[dot + 1:] + if len(display) > width: + display = display[:width - 3] + "..." + return f"{display:{width}s}" + + +def _fine_summary(result, invocations): + schemas = {} + successful = 0 + measurements = 0 + for invocation in invocations: + schemas[str(invocation.version)] = ( + schemas.get(str(invocation.version), 0) + 1) + successful += int(invocation.success) + measurements += sum( + sample.aggregate.count for sample in invocation.samples) + return { + "reports": len(invocations), + "successful_invocations": successful, + "failed_invocations": len(invocations) - successful, + "measurements": measurements, + "schema_versions": schemas, + "malformed_reports": result.malformed, + "unsupported_reports": result.unsupported, + "duplicate_reports": result.duplicates, + } + + +def _location_json(invocation): + return { + "theory": invocation.theory, + "source_file": invocation.source_file or None, + "line": invocation.line, + "command": invocation.command or None, + "command_offset": invocation.command_offset, + "proof": invocation.proof or None, + } + + +def fine_timing_json(session, result, invocations, args): + document = { + "format": "heap-db-inspect/fine-grained-timing", + "version": 1, + "session": session, + "view": args.fine_view, + "group_by": args.fine_group_by, + "summary": _fine_summary(result, invocations), + } + if args.fine_view == "calls": + rows = [] + for invocation in invocations[:args.top]: + row = { + "location": _location_json(invocation), + "invocation": { + "id": invocation.invocation, + "schema_version": invocation.version, + "method": invocation.method, + "success": invocation.success, + "timing_us": ( + None if invocation.timing is None else { + "elapsed": invocation.timing.elapsed_us, + "cpu": invocation.timing.cpu_us, + "gc": invocation.timing.gc_us, + }), + }, + "samples": [], + } + for sample in invocation.samples: + sample_json = { + "name": sample.name, + "success": sample.success, + } + sample_json.update(aggregate_to_json(sample.aggregate)) + row["samples"].append(sample_json) + rows.append(row) + document["rows"] = rows + else: + aggregates = aggregate_invocations( + invocations, + lambda invocation: _fine_group( + invocation, args.fine_group_by)) + rows = [] + for (group, name, success), aggregate in sorted( + aggregates.items(), + key=lambda item: -item[1].timing.elapsed_us)[:args.top]: + row = { + "group": group or None, + "sample": name, + "success": success, + } + row.update(aggregate_to_json(aggregate)) + rows.append(row) + document["rows"] = rows + return document + + +def show_fine_timing_text(result, invocations, args, unavailable): + summary = _fine_summary(result, invocations) + section("Fine-Grained Timing") + print( + f" Reports: {BOLD}{summary['reports']}{RESET} " + f"({summary['successful_invocations']} successful, " + f"{summary['failed_invocations']} failed)") + print(f" Measurements: {BOLD}{summary['measurements']}{RESET}") + versions = ", ".join( + f"v{version}: {count}" + for version, count in sorted(summary["schema_versions"].items())) + print(f" Schemas: {versions or '—'}") + if result.malformed or result.unsupported or result.duplicates: + print( + f" Ignored: {result.malformed} malformed, " + f"{result.unsupported} unsupported, " + f"{result.duplicates} duplicate") + if unavailable: + print( + f" {YELLOW}Source attribution unavailable for " + f"{len(unavailable)} theory/theories; offsets or unknown proof " + f"labels are shown.{RESET}") + if not invocations: + print(f"\n {DIM}(no matching timing reports){RESET}") + return + + if args.fine_view == "calls": + print(f"\n {BOLD}Calls (first {min(args.top, len(invocations))}):{RESET}") + for invocation in invocations[:args.top]: + location = _fine_group(invocation, "command") + print( + f"\n {CYAN}{location}{RESET} " + f"invocation={invocation.invocation}") + print( + f" method={invocation.method} " + f"outcome={'success' if invocation.success else 'failure'}") + if invocation.timing is not None: + print( + f" invocation timing=" + f"{_fmt_micros(invocation.timing.elapsed_us)}") + print( + f"\n {'Count':>7} {'Total':>10} {'CPU':>10} {'GC':>10} " + f"{'Outcome':>8} Sample") + for sample in sorted( + invocation.samples, + key=lambda value: -value.aggregate.timing.elapsed_us): + aggregate = sample.aggregate + print( + f" {aggregate.count:7d} " + f"{_fmt_micros(aggregate.timing.elapsed_us):>10} " + f"{_fmt_micros(aggregate.timing.cpu_us):>10} " + f"{_fmt_micros(aggregate.timing.gc_us):>10} " + f"{'success' if sample.success else 'failure':>8} " + f"{sample.name}") + return + + aggregates = aggregate_invocations( + invocations, + lambda invocation: _fine_group(invocation, args.fine_group_by)) + rows = sorted( + aggregates.items(), key=lambda item: -item[1].timing.elapsed_us) + print( + f"\n {BOLD}Aggregates (top {min(args.top, len(rows))} by total " + f"elapsed):{RESET}\n") + group_heading = ( + f"{'Group':56s} " if args.fine_group_by != "global" else "") + print( + f" {group_heading}{'Total':>10} {'Count':>8} {'Average':>10} " + f"{'p50≤':>10} {'p90≤':>10} {'p99≤':>10} " + f"{'Outcome':>8} Sample") + for (group, name, success), aggregate in rows[:args.top]: + group_text = ( + _display_fine_group(group, args.fine_group_by) + " " + if args.fine_group_by != "global" else "") + average = aggregate.timing.elapsed_us // aggregate.count + print( + f" {group_text}" + f"{_fmt_micros(aggregate.timing.elapsed_us):>10} " + f"{aggregate.count:8d} " + f"{_fmt_micros(average):>10} " + f"{_fmt_micros(percentile_upper_bound(aggregate, 0.50)):>10} " + f"{_fmt_micros(percentile_upper_bound(aggregate, 0.90)):>10} " + f"{_fmt_micros(percentile_upper_bound(aggregate, 0.99)):>10} " + f"{'success' if success else 'failure':>8} {name}") + + def show_ml_stats(conn, session): blob = conn.execute( "SELECT ml_statistics FROM isabelle_session_info WHERE session_name=?", @@ -919,6 +1306,9 @@ def main(): g.add_argument("-d", "--documents", action="store_true", help="Documents") g.add_argument("-c", "--checksums", action="store_true", help="Sources shasum") g.add_argument("-T", "--timings", action="store_true", help="Command timings") + g.add_argument( + "-F", "--fine-timings", action="store_true", + help="Fine-grained PIDE timing reports") g.add_argument("-M", "--ml-stats", action="store_true", help="ML runtime statistics") g.add_argument("-A", "--all", action="store_true", help="Everything") @@ -939,10 +1329,38 @@ def main(): "--isabelle", default=os.environ.get("ISABELLE_TOOL", "isabelle"), help="Isabelle tool used for environment and keyword source lookup") + fine = parser.add_argument_group("fine-grained timing") + fine.add_argument( + "--fine-view", choices=("aggregate", "calls"), default="aggregate", + help="Aggregate samples or show individual calls (default: aggregate)") + fine.add_argument( + "--fine-group-by", + choices=("global", "theory", "proof", "command"), default="global", + help="Aggregate scope (default: global)") + fine.add_argument( + "--fine-method", metavar="REGEX", + help="Restrict invocation labels") + fine.add_argument( + "--fine-sample", metavar="REGEX", + help="Restrict sample labels") + fine.add_argument( + "--fine-invocation-outcome", + choices=("all", "success", "failure"), default="all", + help="Restrict invocation outcomes (default: all)") + fine.add_argument( + "--fine-sample-outcome", + choices=("all", "success", "failure"), default="all", + help="Restrict sample outcomes (default: all)") + fine.add_argument( + "--format", choices=("text", "json"), default="text", + help="Fine-grained timing output format (default: text)") + args = parser.parse_args() if not os.path.isfile(args.db): sys.exit(f"{RED}Error: {args.db} not found{RESET}") + if args.top < 1: + sys.exit(f"{RED}Error: --top must be at least 1{RESET}") session = args.session or os.path.splitext(os.path.basename(args.db))[0] conn = sqlite3.connect(args.db) @@ -950,7 +1368,8 @@ def main(): any_section = (args.build or args.ancestry or args.sources or args.source_summary or args.exports or args.export_summary or args.theories or args.documents or args.checksums or args.timings - or args.ml_stats or args.all or args.timing_range + or args.fine_timings or args.ml_stats or args.all + or args.timing_range or args.annotate_source) if not any_section: args.build = args.ancestry = args.source_summary = True @@ -958,7 +1377,18 @@ def main(): if args.all: args.build = args.ancestry = args.sources = True args.theories = args.documents = args.checksums = True - args.timings = args.ml_stats = True + args.timings = args.fine_timings = args.ml_stats = True + + other_sections = ( + args.build or args.ancestry or args.sources or args.source_summary or + args.exports or args.export_summary or args.theories or + args.documents or args.checksums or args.timings or args.ml_stats or + args.timing_range or args.annotate_source) + if args.format == "json" and (not args.fine_timings or other_sections): + conn.close() + sys.exit( + f"{RED}Error: --format json requires --fine-timings without " + f"other sections{RESET}") # Header heap_dir = os.path.dirname(os.path.dirname(args.db)) @@ -966,10 +1396,11 @@ def main(): heap_size = fmt_size(os.path.getsize(heap_file)) if os.path.isfile(heap_file) else f"{RED}missing{RESET}" db_size = fmt_size(os.path.getsize(args.db)) - print(f"\n{BOLD}Isabelle Heap: {CYAN}{session}{RESET}") - print(f"{'═' * 60}") - print(f" DB: {DIM}{args.db}{RESET} ({db_size})") - print(f" Heap: {DIM}{heap_file}{RESET} ({heap_size})") + if args.format == "text": + print(f"\n{BOLD}Isabelle Heap: {CYAN}{session}{RESET}") + print(f"{'═' * 60}") + print(f" DB: {DIM}{args.db}{RESET} ({db_size})") + print(f" Heap: {DIM}{heap_file}{RESET} ({heap_size})") if args.mismatches: args.check = True @@ -979,12 +1410,13 @@ def main(): # Create source checker if needed checker = None - timing_requested = ( + command_timing_requested = ( args.timings or args.timing_range or args.annotate_source) + timing_requested = command_timing_requested or args.fine_timings if args.check or timing_requested: checker = SourceChecker(conn, session, isabelle_bin=args.isabelle) # Show resolved environment variables - if _isabelle_env_cache: + if args.format == "text" and _isabelle_env_cache: print(f"\n {BOLD}Environment:{RESET}") for (var, _bin), val in sorted(_isabelle_env_cache.items()): if val: @@ -994,7 +1426,43 @@ def main(): ws = args.with_system_sources timing_records = ( - read_command_timings(conn, session) if timing_requested else None) + read_command_timings(conn, session) + if command_timing_requested else None) + + fine_result = None + fine_invocations = None + fine_unavailable = set() + if args.fine_timings: + fine_result, missing_decoder = read_fine_timing_reports( + conn, session, theory=args.theory) + if missing_decoder: + conn.close() + sys.exit( + f"{RED}Error: install Python 'zstandard' or the 'zstd' " + f"command to decode PIDE markup exports{RESET}") + fine_unavailable = annotate_fine_timing_locations( + fine_result.invocations, checker, session, args.isabelle, + need_proofs=args.fine_group_by == "proof") + try: + fine_invocations = filter_fine_timing_invocations( + fine_result.invocations, args) + except ValueError as ex: + conn.close() + sys.exit(f"{RED}Error: {ex}{RESET}") + fine_invocations.sort( + key=lambda invocation: ( + invocation.theory, + invocation.command_offset + if invocation.command_offset is not None else -1, + invocation.invocation)) + + if args.format == "json": + print(json.dumps( + fine_timing_json( + session, fine_result, fine_invocations, args), + indent=2, sort_keys=True)) + conn.close() + return if args.build: show_build(conn, session) if args.ancestry: show_ancestry(conn, session) @@ -1030,6 +1498,9 @@ def main(): show_timings( conn, session, args.top, theory=args.theory, checker=checker, with_system=ws, records=timing_records, isabelle=args.isabelle) + if args.fine_timings: + show_fine_timing_text( + fine_result, fine_invocations, args, fine_unavailable) if args.ml_stats: show_ml_stats(conn, session) if args.sources: show_sources_full(conn, session, grep=args.grep, checker=checker, with_system=ws) diff --git a/ip/test_fine_timing.py b/ip/test_fine_timing.py new file mode 100644 index 00000000..a9c90495 --- /dev/null +++ b/ip/test_fine_timing.py @@ -0,0 +1,193 @@ +#!/usr/bin/env python3 + +import json +import os +import sqlite3 +import subprocess +import sys +import tempfile +import unittest + + +HERE = os.path.dirname(os.path.abspath(__file__)) +sys.path.insert(0, HERE) + +from fine_timing import ( # noqa: E402 + Aggregate, Timing, aggregate_invocations, extract_reports, + percentile_upper_bound, +) + + +X = "\x05" +Y = "\x06" + + +def elem(name, properties=None, body=None): + attributes = "".join( + Y + key + "=" + str(value) + for key, value in (properties or {}).items()) + return ( + X + Y + name + attributes + X + + "".join(body or []) + + X + Y + X) + + +def bucket(index, count): + return elem( + "fine_grained_timing_bucket", + {"bucket": index, "count": count}) + + +def sample(name="step", success=True, count=3): + return elem( + "fine_grained_timing_entry", + { + "name": name, + "success": str(success).lower(), + "count": count, + "elapsed_us": 120, + "cpu_us": 100, + "gc_us": 5, + "min_elapsed_us": 20, + "max_elapsed_us": 60, + }, + [bucket(4, 1), bucket(5, count - 1)]) + + +def transported_report(version=2, invocation=42, success=True, + report_body=None): + properties = { + "xml_name": "fine_grained_timing", + "version": version, + "invocation": invocation, + "method": "example_method", + "success": str(success).lower(), + } + if version == 1: + properties.update({ + "elapsed_us": 500, + "cpu_us": 400, + "gc_us": 10, + }) + return elem( + "xml_elem", properties, + [elem("xml_body", body=report_body or [sample()]), "apply"]) + + +def export_body(report): + return elem( + "command_range", body=[ + elem( + "command_span", + {"name": "apply", "kind": "prf_script"}, + [ + elem( + "entity", + {"name": "apply", "command_offset": 123}), + report, + ]) + ]) + + +class FineTimingDecodeTest(unittest.TestCase): + def test_decodes_transport_and_location(self): + result = extract_reports( + export_body(transported_report()), + "Example.Theory", "PIDE/markup") + self.assertEqual(result.malformed, 0) + self.assertEqual(len(result.invocations), 1) + invocation = result.invocations[0] + self.assertEqual(invocation.invocation, 42) + self.assertEqual(invocation.command, "apply") + self.assertEqual(invocation.command_offset, 123) + self.assertEqual(invocation.samples[0].aggregate.count, 3) + + def test_decodes_legacy_invocation_timing(self): + result = extract_reports( + export_body(transported_report(version=1))) + self.assertEqual(result.invocations[0].timing.elapsed_us, 500) + + def test_rejects_bad_histogram(self): + bad_sample = sample().replace(Y + "count=3", Y + "count=4", 1) + result = extract_reports( + export_body(transported_report(report_body=[bad_sample]))) + self.assertEqual(result.malformed, 1) + self.assertEqual(result.invocations, []) + + def test_counts_unsupported_versions(self): + result = extract_reports( + export_body(transported_report(version=7))) + self.assertEqual(result.unsupported, 1) + self.assertEqual(result.invocations, []) + + def test_handles_deep_pide_markup_without_recursion(self): + report = transported_report() + for _ in range(1200): + report = elem("nested", body=[report]) + result = extract_reports(report) + self.assertEqual(len(result.invocations), 1) + + def test_deduplicates_repeated_transport_records(self): + report = transported_report() + result = extract_reports(report + report) + self.assertEqual(len(result.invocations), 1) + self.assertEqual(result.duplicates, 1) + + def test_merges_samples_and_preserves_histogram(self): + first = extract_reports( + export_body(transported_report(invocation=1))).invocations[0] + second = extract_reports( + export_body(transported_report(invocation=2))).invocations[0] + rows = aggregate_invocations([first, second], lambda _: "") + aggregate = rows[("", "step", True)] + self.assertEqual(aggregate.count, 6) + self.assertEqual(aggregate.timing.elapsed_us, 240) + self.assertEqual(aggregate.histogram, {4: 2, 5: 4}) + + def test_percentiles_are_bucket_upper_bounds(self): + aggregate = Aggregate( + count=4, + timing=Timing(100, 80, 0), + min_elapsed_us=1, + max_elapsed_us=40, + histogram={0: 1, 3: 3}) + self.assertEqual(percentile_upper_bound(aggregate, 0.25), 1) + self.assertEqual(percentile_upper_bound(aggregate, 0.50), 15) + + +class FineTimingCLITest(unittest.TestCase): + def test_json_output_is_machine_readable(self): + with tempfile.TemporaryDirectory() as directory: + database = os.path.join(directory, "Example.db") + connection = sqlite3.connect(database) + connection.execute( + "CREATE TABLE isabelle_exports (" + "session_name TEXT, theory_name TEXT, name TEXT, body BLOB)") + connection.execute( + "CREATE TABLE isabelle_sources (" + "session_name TEXT, name TEXT, digest TEXT)") + connection.execute( + "INSERT INTO isabelle_exports VALUES (?, ?, ?, ?)", + ("Example", "Example.Theory", "PIDE/markup", + export_body(transported_report()).encode("utf-8"))) + connection.commit() + connection.close() + + process = subprocess.run( + [ + os.path.join(HERE, "heap-db-inspect"), + database, + "--fine-timings", + "--format", "json", + ], + check=True, capture_output=True, text=True) + document = json.loads(process.stdout) + self.assertEqual( + document["format"], + "heap-db-inspect/fine-grained-timing") + self.assertEqual(document["summary"]["reports"], 1) + self.assertEqual(document["rows"][0]["sample"], "step") + + +if __name__ == "__main__": + unittest.main() diff --git a/ir/heap_info.py b/ir/heap_info.py index fa1bd5dc..14b95965 100644 --- a/ir/heap_info.py +++ b/ir/heap_info.py @@ -189,9 +189,17 @@ def decompress_blob(blob): if not blob: return "" if blob[:4] == b'\x28\xb5\x2f\xfd': # zstd magic - if not HAS_ZSTD: - return None # signal missing dependency - data = zstandard.ZstdDecompressor().decompress(blob, max_output_size=50*1024*1024) + if HAS_ZSTD: + data = zstandard.ZstdDecompressor().decompress( + blob, max_output_size=50*1024*1024) + else: + try: + process = subprocess.run( + ["zstd", "-q", "-d", "-c"], + input=blob, capture_output=True, check=True) + data = process.stdout + except (OSError, subprocess.CalledProcessError): + return None # signal missing decoder return data.decode("utf-8", errors="replace") return blob.decode("utf-8", errors="replace") if isinstance(blob, bytes) else blob From cf58765b9972e94f98b52b88a1ddbfa5b937697a Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:29 +0100 Subject: [PATCH 14/46] Scala plugins: Normalize Isabelle installation paths The I/Q, Isabelle Assistant, and I/P plugin Makefiles accepted the Isabelle installation root or its `bin` directory for the launcher. They still derived Scala and library paths from the raw value, so the `bin` form searched below `bin/contrib`. Normalize the launcher input once. Derive jEdit, Scala, the Isabelle JAR, and plugin dependencies from the installation root. Preserve explicit `ISABELLE`, `SCALA_HOME`, and `SCALAC` overrides. Signed-off-by: Hanno Becker --- ip/ip_plugin/Makefile | 14 +++++++++++--- iq/Makefile | 22 +++++++++++++++------- isabelle-assistant/Makefile | 16 ++++++++++++---- 3 files changed, 38 insertions(+), 14 deletions(-) diff --git a/ip/ip_plugin/Makefile b/ip/ip_plugin/Makefile index 797202c5..18e47e0a 100644 --- a/ip/ip_plugin/Makefile +++ b/ip/ip_plugin/Makefile @@ -6,11 +6,19 @@ endif PLUGIN_DIR := $(shell pwd) ISABELLE_HOME ?= /Applications/Isabelle2025-2.app -JEDIT_DIR := $(shell ls -d $(ISABELLE_HOME)/contrib/jedit-* 2>/dev/null | head -1) +ifneq ($(wildcard $(ISABELLE_HOME)/bin/isabelle),) +ISABELLE_INSTALLATION_HOME := $(abspath $(ISABELLE_HOME)) +else ifneq ($(wildcard $(ISABELLE_HOME)/isabelle),) +ISABELLE_INSTALLATION_HOME := $(abspath $(ISABELLE_HOME)/..) +else +$(warning Cannot find Isabelle under $(ISABELLE_HOME)/bin/isabelle or $(ISABELLE_HOME)/isabelle; treating ISABELLE_HOME as the installation root) +ISABELLE_INSTALLATION_HOME := $(abspath $(ISABELLE_HOME)) +endif +JEDIT_DIR := $(shell ls -d $(ISABELLE_INSTALLATION_HOME)/contrib/jedit-* 2>/dev/null | head -1) JEDIT_JAR ?= $(JEDIT_DIR)/jedit5.7.0-patched/jedit.jar -SCALA_HOME ?= $(ISABELLE_HOME)/contrib/scala-3.3.4 +SCALA_HOME ?= $(ISABELLE_INSTALLATION_HOME)/contrib/scala-3.3.4 SCALAC ?= $(SCALA_HOME)/bin/scalac -ISABELLE_JAR ?= $(ISABELLE_HOME)/lib/classes/isabelle.jar +ISABELLE_JAR ?= $(ISABELLE_INSTALLATION_HOME)/lib/classes/isabelle.jar BUILD_DIR ?= $(PLUGIN_DIR)/build CLASSES_DIR ?= $(BUILD_DIR)/classes diff --git a/iq/Makefile b/iq/Makefile index a355ff26..05d76769 100644 --- a/iq/Makefile +++ b/iq/Makefile @@ -8,17 +8,25 @@ endif # Paths (configurable via environment variables) PLUGIN_DIR := $(shell pwd) ISABELLE_HOME ?= /Applications/Isabelle2025-2.app -ISABELLE ?= $(if $(wildcard $(ISABELLE_HOME)/bin/isabelle),$(ISABELLE_HOME)/bin/isabelle,$(ISABELLE_HOME)/isabelle) -JEDIT_DIR := $(shell ls -d $(ISABELLE_HOME)/contrib/jedit-* 2>/dev/null | head -1) +ifneq ($(wildcard $(ISABELLE_HOME)/bin/isabelle),) +ISABELLE_INSTALLATION_HOME := $(abspath $(ISABELLE_HOME)) +else ifneq ($(wildcard $(ISABELLE_HOME)/isabelle),) +ISABELLE_INSTALLATION_HOME := $(abspath $(ISABELLE_HOME)/..) +else +$(warning Cannot find Isabelle under $(ISABELLE_HOME)/bin/isabelle or $(ISABELLE_HOME)/isabelle; treating ISABELLE_HOME as the installation root) +ISABELLE_INSTALLATION_HOME := $(abspath $(ISABELLE_HOME)) +endif +ISABELLE ?= $(ISABELLE_INSTALLATION_HOME)/bin/isabelle +JEDIT_DIR := $(shell ls -d $(ISABELLE_INSTALLATION_HOME)/contrib/jedit-* 2>/dev/null | head -1) JEDIT_JAR ?= $(JEDIT_DIR)/jedit5.7.0-patched/jedit.jar -SCALA_HOME ?= $(ISABELLE_HOME)/contrib/scala-3.3.4 +SCALA_HOME ?= $(ISABELLE_INSTALLATION_HOME)/contrib/scala-3.3.4 SCALAC ?= $(SCALA_HOME)/bin/scalac SCALAC_FLAGS ?= -deprecation -feature -unchecked -Werror -Wunused:imports,privates,locals,params -Xlint:all -Wvalue-discard -Wnonunit-statement SCALA ?= $(SCALA_HOME)/bin/scala SCALA_PARSER_JAR := $(wildcard $(SCALA_HOME)/lib/scala-parser-combinators_3-*.jar) -XZ_JAR := $(firstword $(wildcard $(ISABELLE_HOME)/contrib/xz-java-*/lib/xz-*.jar $(ISABELLE_HOME)/contrib/xz-java-*/lib/xz.jar)) -ZSTD_JAR := $(firstword $(wildcard $(ISABELLE_HOME)/contrib/zstd-jni-*/lib/zstd-jni-*.jar)) -ISABELLE_JAR ?= $(ISABELLE_HOME)/lib/classes/isabelle.jar +XZ_JAR := $(firstword $(wildcard $(ISABELLE_INSTALLATION_HOME)/contrib/xz-java-*/lib/xz-*.jar $(ISABELLE_INSTALLATION_HOME)/contrib/xz-java-*/lib/xz.jar)) +ZSTD_JAR := $(firstword $(wildcard $(ISABELLE_INSTALLATION_HOME)/contrib/zstd-jni-*/lib/zstd-jni-*.jar)) +ISABELLE_JAR ?= $(ISABELLE_INSTALLATION_HOME)/lib/classes/isabelle.jar JAVA_HOME ?= $(shell $(ISABELLE) getenv -b JAVA_HOME 2>/dev/null) JAVA ?= $(if $(JAVA_HOME),$(JAVA_HOME)/bin/java,java) JAR ?= $(if $(JAVA_HOME),$(JAVA_HOME)/bin/jar,jar) @@ -154,7 +162,7 @@ install: $(JAR_FILE) echo " Atomic install avoids partial writes, but a running classloader keeps old JAR state." echo "" echo "To use the plugin:" - echo "1. Start Isabelle/jEdit: $(ISABELLE_HOME)/bin/isabelle jedit" + echo "1. Start Isabelle/jEdit: $(ISABELLE_INSTALLATION_HOME)/bin/isabelle jedit" echo "2. Go to Utilities -> Global Options -> Plugin Manager" echo "3. The I/Q Plugin should be listed and active" echo "4. Go to Utilities -> I/Q Server Log to open the dockable" diff --git a/isabelle-assistant/Makefile b/isabelle-assistant/Makefile index da274543..ac08c440 100644 --- a/isabelle-assistant/Makefile +++ b/isabelle-assistant/Makefile @@ -6,10 +6,18 @@ endif PLUGIN_DIR := $(shell pwd) ISABELLE_HOME ?= /Applications/Isabelle2025-2.app -ISABELLE ?= $(if $(wildcard $(ISABELLE_HOME)/bin/isabelle),$(ISABELLE_HOME)/bin/isabelle,$(ISABELLE_HOME)/isabelle) -JEDIT_DIR := $(shell ls -d $(ISABELLE_HOME)/contrib/jedit-* 2>/dev/null | head -1) +ifneq ($(wildcard $(ISABELLE_HOME)/bin/isabelle),) +ISABELLE_INSTALLATION_HOME := $(abspath $(ISABELLE_HOME)) +else ifneq ($(wildcard $(ISABELLE_HOME)/isabelle),) +ISABELLE_INSTALLATION_HOME := $(abspath $(ISABELLE_HOME)/..) +else +$(warning Cannot find Isabelle under $(ISABELLE_HOME)/bin/isabelle or $(ISABELLE_HOME)/isabelle; treating ISABELLE_HOME as the installation root) +ISABELLE_INSTALLATION_HOME := $(abspath $(ISABELLE_HOME)) +endif +ISABELLE ?= $(ISABELLE_INSTALLATION_HOME)/bin/isabelle +JEDIT_DIR := $(shell ls -d $(ISABELLE_INSTALLATION_HOME)/contrib/jedit-* 2>/dev/null | head -1) JEDIT_JAR ?= $(JEDIT_DIR)/jedit5.7.0-patched/jedit.jar -SCALA_HOME ?= $(ISABELLE_HOME)/contrib/scala-3.3.4 +SCALA_HOME ?= $(ISABELLE_INSTALLATION_HOME)/contrib/scala-3.3.4 SCALAC ?= $(SCALA_HOME)/bin/scalac SCALAC_FLAGS ?= -deprecation -feature -unchecked -Werror -Wunused:imports,privates,locals,params -Xlint:all -Wvalue-discard -Wnonunit-statement # Test flags mirror the production flags except for -Wnonunit-statement: @@ -18,7 +26,7 @@ SCALAC_FLAGS ?= -deprecation -feature -unchecked -Werror -Wunused:imports,privat # assertion. Keep -Werror and -Wvalue-discard — they catch real mistakes # without interfering with idiomatic test bodies. TEST_SCALAC_FLAGS ?= -deprecation -feature -unchecked -Werror -Wunused:imports,privates,locals,params -Xlint:all -Wvalue-discard -ISABELLE_JAR ?= $(ISABELLE_HOME)/lib/classes/isabelle.jar +ISABELLE_JAR ?= $(ISABELLE_INSTALLATION_HOME)/lib/classes/isabelle.jar JAVA_HOME ?= $(shell $(ISABELLE) getenv -b JAVA_HOME 2>/dev/null) JAVA ?= $(if $(JAVA_HOME),$(JAVA_HOME)/bin/java,java) JAR ?= $(if $(JAVA_HOME),$(JAVA_HOME)/bin/jar,jar) From 3a7cc1aa3d151a50d07d1f7b07759282009ddfc9 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:29 +0100 Subject: [PATCH 15/46] Fine-Grained Timing: Build source hierarchy asynchronously The timing panel flattened each scope into one table. Adding a source hierarchy made Global decode every document command and build every row on the Swing event thread. Each level also rescanned the same invocations, so a large session could wedge jEdit before repainting. Make timing signals the roots and expand through theory, proof, command, and detail context as the scope permits. Build reusable call and aggregate indexes per command. Merge cached node indexes for Global scope, and preserve zero-sample calls as zero aggregates. Decode PIDE reports, build indexes, format rows, and construct expanded children in cancellable Isabelle futures. Initially create only signal roots, rebuild only changed nodes, reject superseded generations, and invalidate caches when the dockable closes. Apply thresholds at the displayed level and keep qualified proof names distinct. Persist column visibility and timing precision. Use numeric sorting for flat rows, replace Crush-specific categories with a generic name filter, and normalize the component Makefile path. Keep expansion stable across refreshes and disable sorting while hierarchical rows are visible. Signed-off-by: Hanno Becker --- Fine_Grained_Timing/Makefile | 24 +- Fine_Grained_Timing/resources/plugin.props | 2 +- .../src/FineGrainedTiming.scala | 7 +- .../src/FineGrainedTimingDockable.scala | 1379 ++++++++++++++--- .../src/FineGrainedTimingHierarchy.scala | 164 ++ .../src/FineGrainedTimingScope.scala | 7 + .../src/FineGrainedTimingTreeTable.scala | 375 +++++ .../test/FineGrainedTimingHierarchyTest.scala | 172 ++ .../test/FineGrainedTimingScopeTest.scala | 11 + .../test/FineGrainedTimingTest.scala | 10 + .../test/FineGrainedTimingTreeTableTest.scala | 119 ++ 11 files changed, 2023 insertions(+), 247 deletions(-) create mode 100644 Fine_Grained_Timing/src/FineGrainedTimingHierarchy.scala create mode 100644 Fine_Grained_Timing/src/FineGrainedTimingTreeTable.scala create mode 100644 Fine_Grained_Timing/test/FineGrainedTimingHierarchyTest.scala create mode 100644 Fine_Grained_Timing/test/FineGrainedTimingTreeTableTest.scala diff --git a/Fine_Grained_Timing/Makefile b/Fine_Grained_Timing/Makefile index 3d4489bd..db9bc9e5 100644 --- a/Fine_Grained_Timing/Makefile +++ b/Fine_Grained_Timing/Makefile @@ -6,14 +6,22 @@ endif COMPONENT_DIR := $(shell pwd) ISABELLE_HOME ?= /Applications/Isabelle2025-2.app -ISABELLE ?= $(if $(wildcard $(ISABELLE_HOME)/bin/isabelle),$(ISABELLE_HOME)/bin/isabelle,$(ISABELLE_HOME)/isabelle) -JEDIT_DIR := $(shell ls -d $(ISABELLE_HOME)/contrib/jedit-* 2>/dev/null | head -1) +ifneq ($(wildcard $(ISABELLE_HOME)/bin/isabelle),) +ISABELLE_INSTALLATION_HOME := $(abspath $(ISABELLE_HOME)) +else ifneq ($(wildcard $(ISABELLE_HOME)/isabelle),) +ISABELLE_INSTALLATION_HOME := $(abspath $(ISABELLE_HOME)/..) +else +$(warning Cannot find Isabelle under $(ISABELLE_HOME)/bin/isabelle or $(ISABELLE_HOME)/isabelle; treating ISABELLE_HOME as the installation root) +ISABELLE_INSTALLATION_HOME := $(abspath $(ISABELLE_HOME)) +endif +ISABELLE ?= $(ISABELLE_INSTALLATION_HOME)/bin/isabelle +JEDIT_DIR := $(shell ls -d $(ISABELLE_INSTALLATION_HOME)/contrib/jedit-* 2>/dev/null | head -1) JEDIT_JAR ?= $(JEDIT_DIR)/jedit5.7.0-patched/jedit.jar -SCALA_HOME ?= $(ISABELLE_HOME)/contrib/scala-3.3.4 +SCALA_HOME ?= $(ISABELLE_INSTALLATION_HOME)/contrib/scala-3.3.4 SCALAC ?= $(SCALA_HOME)/bin/scalac SCALA_FLAGS ?= -deprecation -feature -unchecked -Werror -Wunused:imports,privates,locals,params -Xlint:all -Wvalue-discard -Wnonunit-statement SCALA ?= $(SCALA_HOME)/bin/scala -ISABELLE_JAR ?= $(ISABELLE_HOME)/lib/classes/isabelle.jar +ISABELLE_JAR ?= $(ISABELLE_INSTALLATION_HOME)/lib/classes/isabelle.jar JAVA_HOME ?= $(shell $(ISABELLE) getenv -b JAVA_HOME 2>/dev/null) JAR ?= $(if $(JAVA_HOME),$(JAVA_HOME)/bin/jar,jar) JAVA_ENV = $(if $(JAVA_HOME),JAVA_HOME="$(JAVA_HOME)" PATH="$(JAVA_HOME)/bin:$$PATH",) @@ -45,6 +53,14 @@ test: build $(TEST_CLASSES_DIR)/.compiled $(JAVA_ENV) $(SCALA) \ -classpath "$(TEST_CLASSPATH)" \ FineGrainedTimingScopeTest + echo "Running timing hierarchy tests..." + $(JAVA_ENV) $(SCALA) \ + -classpath "$(TEST_CLASSPATH)" \ + FineGrainedTimingHierarchyTest + echo "Running timing tree-table tests..." + $(JAVA_ENV) $(SCALA) -Djava.awt.headless=true \ + -classpath "$(TEST_CLASSPATH)" \ + FineGrainedTimingTreeTableTest echo "Fine-Grained Timing Scala tests passed." session-test: diff --git a/Fine_Grained_Timing/resources/plugin.props b/Fine_Grained_Timing/resources/plugin.props index f7c5fb46..32076730 100644 --- a/Fine_Grained_Timing/resources/plugin.props +++ b/Fine_Grained_Timing/resources/plugin.props @@ -3,7 +3,7 @@ plugin.FineGrainedTimingPlugin.name=Fine-Grained Timing plugin.FineGrainedTimingPlugin.author=Amazon Web Services plugin.FineGrainedTimingPlugin.version=1.0 -plugin.FineGrainedTimingPlugin.description=Fine-grained tactic timing for Isabelle/jEdit +plugin.FineGrainedTimingPlugin.description=Fine-grained prover timing for Isabelle/jEdit plugin.FineGrainedTimingPlugin.activate=defer plugin.FineGrainedTimingPlugin.usePluginHome=false diff --git a/Fine_Grained_Timing/src/FineGrainedTiming.scala b/Fine_Grained_Timing/src/FineGrainedTiming.scala index 25abbce0..4da3de19 100644 --- a/Fine_Grained_Timing/src/FineGrainedTiming.scala +++ b/Fine_Grained_Timing/src/FineGrainedTiming.scala @@ -26,7 +26,10 @@ object FineGrainedTiming { maxElapsedMicros: Long, histogram: Map[Int, Long] ) { - def +(other: Aggregate): Aggregate = { + def +(other: Aggregate): Aggregate = + if (count == 0L) other + else if (other.count == 0L) this + else { val mergedHistogram = (histogram.keySet ++ other.histogram.keySet).iterator.map { bucket => bucket -> (histogram.getOrElse(bucket, 0L) + other.histogram.getOrElse(bucket, 0L)) @@ -38,7 +41,7 @@ object FineGrainedTiming { maxElapsedMicros = math.max(maxElapsedMicros, other.maxElapsedMicros), histogram = mergedHistogram ) - } + } def averageElapsedMicros: Double = if (count == 0L) 0.0 else timing.elapsedMicros.toDouble / count.toDouble diff --git a/Fine_Grained_Timing/src/FineGrainedTimingDockable.scala b/Fine_Grained_Timing/src/FineGrainedTimingDockable.scala index 2a3e5404..bde562ba 100644 --- a/Fine_Grained_Timing/src/FineGrainedTimingDockable.scala +++ b/Fine_Grained_Timing/src/FineGrainedTimingDockable.scala @@ -1,25 +1,41 @@ /* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. SPDX-License-Identifier: MIT */ -import java.awt.{BorderLayout, FlowLayout} +import java.awt.{BorderLayout, FlowLayout, GridLayout} import java.awt.event.{ActionEvent, ActionListener, MouseAdapter, MouseEvent} +import java.util.Locale import javax.swing.{ + JButton, JCheckBox, JComboBox, JLabel, JPanel, + JOptionPane, JScrollPane, - JTable, JTextField } -import javax.swing.table.AbstractTableModel +import javax.swing.event.{TreeExpansionEvent, TreeWillExpandListener} +import javax.swing.table.TableColumn -import scala.collection.mutable import scala.annotation.unused -import isabelle.{Command, Document, GUI_Thread, Markup, Session, Text} +import isabelle.{ + Command, + Document, + Document_ID, + Exn, + Future, + GUI_Thread, + Line, + Markup, + Output, + Session, + Synchronized, + Text +} import isabelle.jedit.PIDE +import org.gjt.sp.jedit.jEdit import org.gjt.sp.jedit.View import org.gjt.sp.jedit.gui.DefaultFocusComponent @@ -31,107 +47,190 @@ extends JPanel(new BorderLayout) with DefaultFocusComponent { private val ScopeGlobal = "Global" private val CallsView = "Calls" private val AggregateView = "Aggregate" + private val VisibleColumnsProperty = "fine-grained-timing.visible-columns" + private val TimingDigitsProperty = "fine-grained-timing.timing-digits" + private val DefaultTimingDigits = 3 + private val MinTimingDigits = 0 + private val MaxTimingDigits = 9 + + private final case class ColumnDescriptor( + id: String, + title: String, + defaultVisible: Boolean + ) - private val columns = - Vector("Location", "Name", "Outcome", "Count", "Total", "Average", - "p50", "p90", "p99", "Min", "Max", "CPU", "GC") + private val columnDescriptors = Vector( + ColumnDescriptor("location", "Location", defaultVisible = true), + ColumnDescriptor("name", "Name", defaultVisible = true), + ColumnDescriptor("outcome", "Outcome", defaultVisible = true), + ColumnDescriptor("count", "Count", defaultVisible = true), + ColumnDescriptor("total", "Total", defaultVisible = true), + ColumnDescriptor("average", "Average", defaultVisible = false), + ColumnDescriptor("p50", "p50", defaultVisible = true), + ColumnDescriptor("p90", "p90", defaultVisible = true), + ColumnDescriptor("p99", "p99", defaultVisible = true), + ColumnDescriptor("min", "Min", defaultVisible = false), + ColumnDescriptor("max", "Max", defaultVisible = true) + ) + private val columnIndex = + columnDescriptors.iterator.zipWithIndex.map { case (column, index) => + column.id -> index + }.toMap private final case class CommandTiming( command: Command, - index: Int, theory: String, + proof: Option[String], + proofStart: Option[Command], + line: Int, invocations: Vector[FineGrainedTiming.Invocation] ) - private sealed trait TimingRow { - def command: Command - def values: Vector[String] - } + private final case class ProofContext(name: String, start: Command) - private final case class InvocationRow( - command: Command, - location: String, - invocation: FineGrainedTiming.Invocation - ) extends TimingRow { - def values: Vector[String] = { - val sampleCount = invocation.samples.iterator.map(_.aggregate.count).sum - val elapsed = invocation.timing.map(timing => formatMicros(timing.elapsedMicros)) - val cpu = invocation.timing.map(timing => formatMicros(timing.cpuMicros)) - val gc = invocation.timing.map(timing => formatMicros(timing.gcMicros)) - Vector( - location, - invocation.method, - if (invocation.success) "success" else "failure", - sampleCount.toString, - elapsed.getOrElse(""), - "", - "", - "", - "", - "", - "", - cpu.getOrElse(""), - gc.getOrElse("") - ) - } - } + private final case class IndexOptions( + view: FineGrainedTimingHierarchy.View, + nameFilter: String, + showSuccess: Boolean, + showFailure: Boolean + ) - private final case class AggregateRow( - command: Command, + private final case class DisplayOptions( + expandedNodes: Set[String], + timingDigits: Int, + thresholdMicros: Double + ) + + private final case class RenderState( + index: FineGrainedTimingHierarchy.Index[CommandTiming], + scope: String, + view: FineGrainedTimingHierarchy.View, location: String, - key: FineGrainedTiming.SampleKey, - aggregate: FineGrainedTiming.Aggregate - ) extends TimingRow { - def values: Vector[String] = - Vector( - location, - key.name, - if (key.success) "success" else "failure", - aggregate.count.toString, - formatMicros(aggregate.timing.elapsedMicros), - formatMicros(aggregate.averageElapsedMicros), - formatMicros(aggregate.percentileElapsedMicros(0.50)), - formatMicros(aggregate.percentileElapsedMicros(0.90)), - formatMicros(aggregate.percentileElapsedMicros(0.99)), - formatMicros(aggregate.minElapsedMicros), - formatMicros(aggregate.maxElapsedMicros), - formatMicros(aggregate.timing.cpuMicros), - formatMicros(aggregate.timing.gcMicros) - ) + navigation: NavigationTarget + ) + + private final case class GlobalRefreshResult( + renderState: RenderState, + tree: Vector[FineGrainedTimingTreeTable.Data], + timings: Map[Document.Node.Name, Vector[CommandTiming]], + indexes: Map[ + Document.Node.Name, + FineGrainedTimingHierarchy.Index[CommandTiming] + ], + indexOptions: IndexOptions, + domain: Set[Document.Node.Name], + refreshedNodes: Set[Document.Node.Name], + version: Document_ID.Version + ) + + private sealed trait NavigationTarget { + def follow(snapshot: Document.Snapshot): Unit } - private final class TimingTableModel extends AbstractTableModel { - private var rows = Vector.empty[TimingRow] + private case object NoNavigation extends NavigationTarget { + override def follow(snapshot: Document.Snapshot): Unit = { + val _ = snapshot + } + } - def update(newRows: Vector[TimingRow]): Unit = { - rows = newRows - fireTableDataChanged() + private final case class TheoryNavigation(name: Document.Node.Name) + extends NavigationTarget { + override def follow(snapshot: Document.Snapshot): Unit = { + val _ = snapshot + PIDE.editor.goto_file(view, name.node, line = 0, focus = true) } + } - def row(index: Int): Option[TimingRow] = rows.lift(index) + private final case class CommandNavigation(command: Command) + extends NavigationTarget { + override def follow(snapshot: Document.Snapshot): Unit = + PIDE.editor.hyperlink_command( + snapshot, + command.id, + focus = true + ).foreach(_.follow(view)) + } - override def getRowCount: Int = rows.length - override def getColumnCount: Int = columns.length - override def getColumnName(column: Int): String = columns(column) - override def getValueAt(row: Int, column: Int): Object = rows(row).values(column) + private sealed trait TimingRow { + def navigation: NavigationTarget + def nodeId: String + def values: Vector[String] } - private val tableModel = new TimingTableModel - private val table = new JTable(tableModel) - table.setAutoCreateRowSorter(true) + private final case class DetailRow( + navigation: NavigationTarget, + nodeId: String, + values: Vector[String] + ) extends TimingRow + + private final case class GroupRow( + navigation: NavigationTarget, + nodeId: String, + values: Vector[String] + ) extends TimingRow + + private val treeTableColumns = + new FineGrainedTimingTreeTable.Columns { + override def count: Int = columnDescriptors.length + override def name(column: Int): String = + columnDescriptors(column).title + override def columnClass(column: Int): Class[?] = + if (column == columnIndex("location")) + classOf[FineGrainedTimingTreeTable.TreeColumn] + else classOf[String] + override def valueAt(value: AnyRef, column: Int): AnyRef = + value match { + case row: TimingRow => row.values(column) + case FineGrainedTimingTreeTable.Loading => + if (column == columnIndex("location")) "Loading..." else "" + case _ => "" + } + } + private val treeModel = + new FineGrainedTimingTreeTable.Model(treeTableColumns) + private val table = + new FineGrainedTimingTreeTable.Table( + treeModel, + columnIndex("location") + ) + table.setAutoCreateColumnsFromModel(false) table.setFillsViewportHeight(true) + private var visibleColumnIds = loadVisibleColumnIds() + private var expandedNodes = Set.empty[String] + private var restoringTreeExpansion = false + applyVisibleColumns() + table.tree.addTreeWillExpandListener(new TreeWillExpandListener { + override def treeWillExpand(event: TreeExpansionEvent): Unit = + if (!restoringTreeExpansion) { + treeModel.value(event.getPath.getLastPathComponent) match { + case group: GroupRow if !expandedNodes.contains(group.nodeId) => + expandedNodes += group.nodeId + rerenderCurrent() + case _ => + } + } + + override def treeWillCollapse(event: TreeExpansionEvent): Unit = + if (!restoringTreeExpansion) { + treeModel.value(event.getPath.getLastPathComponent) match { + case group: GroupRow if expandedNodes.contains(group.nodeId) => + expandedNodes -= group.nodeId + rerenderCurrent() + case _ => + } + } + }) table.addMouseListener(new MouseAdapter { override def mouseClicked(event: MouseEvent): Unit = { - if (event.getClickCount == 2) { - val viewRow = table.rowAtPoint(event.getPoint) - if (viewRow >= 0) { - val modelRow = table.convertRowIndexToModel(viewRow) - for { - row <- tableModel.row(modelRow) - hyperlink <- PIDE.editor.hyperlink_command( - PIDE.session.snapshot(), row.command.id, focus = true) - } hyperlink.follow(view) - } + val viewRow = table.rowAtPoint(event.getPoint) + if (event.getClickCount == 2 && viewRow >= 0) { + for { + value <- table.valueAtRow(viewRow) + row <- value match { + case timingRow: TimingRow => Some(timingRow) + case _ => None + } + } row.navigation.follow(PIDE.session.snapshot()) } } }) @@ -140,15 +239,13 @@ extends JPanel(new BorderLayout) with DefaultFocusComponent { new JComboBox[String](Array(ScopeCommand, ScopeProof, ScopeTheory, ScopeGlobal)) private val viewSelector = new JComboBox[String](Array(AggregateView, CallsView)) - private val categorySelector = - new JComboBox[String]( - Array("all", "branch", "step", "call", "clarsimp", "seplog", - "transaction", "setup", "other") - ) + private val columnsButton = new JButton("Columns...") + private val filterField = new JTextField("", 14) private val showSuccess = new JCheckBox("Success", true) private val showFailure = new JCheckBox("Failure", true) private val thresholdField = new JTextField("0.000", 6) - private val currentLabel = new JLabel("No active theory") + private var timingDigits = loadTimingDigits() + private val timingDigitsField = new JTextField(timingDigits.toString, 2) private val refreshListener = new ActionListener { override def actionPerformed(event: ActionEvent): Unit = { @@ -158,101 +255,345 @@ extends JPanel(new BorderLayout) with DefaultFocusComponent { } scopeSelector.addActionListener(refreshListener) viewSelector.addActionListener(refreshListener) - categorySelector.addActionListener(refreshListener) + columnsButton.addActionListener(new ActionListener { + override def actionPerformed(event: ActionEvent): Unit = { + val _ = event + showColumnDialog() + } + }) + filterField.addActionListener(refreshListener) showSuccess.addActionListener(refreshListener) showFailure.addActionListener(refreshListener) - thresholdField.addActionListener(refreshListener) + thresholdField.addActionListener(new ActionListener { + override def actionPerformed(event: ActionEvent): Unit = { + val _ = event + if (currentRenderState.nonEmpty) rerenderCurrent() else refresh() + } + }) + timingDigitsField.addActionListener(new ActionListener { + override def actionPerformed(event: ActionEvent): Unit = { + val _ = event + updateTimingDigits() + } + }) private val controls = new JPanel(new FlowLayout(FlowLayout.LEFT, 6, 2)) controls.add(new JLabel("Scope:")) controls.add(scopeSelector) controls.add(new JLabel("View:")) controls.add(viewSelector) - controls.add(new JLabel("Category:")) - controls.add(categorySelector) + columnsButton.setToolTipText("Choose which timing columns are visible") + controls.add(columnsButton) + controls.add(new JLabel("Filter:")) + filterField.setToolTipText( + "Show rows whose method or sample name contains this text" + ) + controls.add(filterField) controls.add(showSuccess) controls.add(showFailure) controls.add(new JLabel("Threshold (s):")) controls.add(thresholdField) - controls.add(currentLabel) + controls.add(new JLabel("Digits:")) + timingDigitsField.setToolTipText( + "Number of fractional digits shown for timing values (0-9)" + ) + controls.add(timingDigitsField) add(controls, BorderLayout.NORTH) add(new JScrollPane(table), BorderLayout.CENTER) private var globalTimings = Map.empty[Document.Node.Name, Vector[CommandTiming]] + private var globalIndexes = + Map.empty[ + Document.Node.Name, + FineGrainedTimingHierarchy.Index[CommandTiming] + ] + private var globalIndexOptions = Option.empty[IndexOptions] + private var globalVersion = Option.empty[Document_ID.Version] + private var dirtyGlobalNodes = Set.empty[Document.Node.Name] + private var currentRenderState = Option.empty[RenderState] + private var refreshGeneration = 0L + private val futureRefresh = + Synchronized[Option[Future[Unit]]](None) private def refresh( changedNodes: Option[Set[Document.Node.Name]] = None ): Unit = { GUI_Thread.require {} - val sessionSnapshot = PIDE.session.snapshot() - if (globalTimings.nonEmpty) updateGlobalTimings(sessionSnapshot, changedNodes) - - if (scopeSelector.getSelectedItem.toString == ScopeGlobal) { - if (globalTimings.isEmpty) updateGlobalTimings(sessionSnapshot, None) - val selected = globalTimings.toVector.sortBy(_._1.theory).flatMap(_._2) - val theoryCount = - selected.iterator.filter(_.invocations.nonEmpty).map(_.theory).toSet.size - val location = s"Global: $theoryCount theories" - currentLabel.setText(location) - tableModel.update(makeRows(selected, location)) - } else PIDE.editor.current_node_snapshot(view) match { - case Some(snapshot) if !snapshot.is_outdated => - val node = snapshot.node - val commandPairs = node.command_iterator().toVector - val scopeCommands = - commandPairs.map { case (command, offset) => - FineGrainedTimingScope.ScopeCommand(command.span.name, offset, command.length) - } - val proofs = FineGrainedTimingScope.partitionNamedProofs(scopeCommands) - val currentCommand = PIDE.editor.current_command(view, snapshot) - val currentIndex = - currentCommand.flatMap(command => commandPairs.indexWhere(_._1.id == command.id) match { + changedNodes.foreach(nodes => dirtyGlobalNodes ++= nodes) + cancelRefresh() + + val scope = scopeSelector.getSelectedItem.toString + val indexOptions = captureIndexOptions() + val displayOptions = captureDisplayOptions() + if (scope == ScopeGlobal) { + startGlobalRefresh( + PIDE.session.snapshot(), + indexOptions, + displayOptions + ) + } else { + PIDE.editor.current_node_snapshot(view) match { + case Some(snapshot) if !snapshot.is_outdated => + val currentCommandId = + PIDE.editor.current_command(view, snapshot).map(_.id) + startLocalRefresh( + snapshot, + currentCommandId, + scope, + indexOptions, + displayOptions + ) + case _ => + updateTree(Vector.empty) + } + } + } + + private def startLocalRefresh( + snapshot: Document.Snapshot, + currentCommandId: Option[Document_ID.Command], + scope: String, + indexOptions: IndexOptions, + displayOptions: DisplayOptions + ): Unit = { + forkRefresh { + val node = snapshot.node + val commandPairs = node.command_iterator().toVector + val scopeCommands = + commandPairs.map { case (command, offset) => + FineGrainedTimingScope.ScopeCommand( + command.span.name, + offset, + command.length + ) + } + val proofs = FineGrainedTimingScope.partitionNamedProofs(scopeCommands) + val proofContexts = proofContextsByCommand(proofs, commandPairs) + val currentIndex = + currentCommandId.flatMap { id => + commandPairs.indexWhere(_._1.id == id) match { case index if index >= 0 => Some(index) case _ => None - }) - val timings = - commandPairs.zipWithIndex.map { case ((command, offset), index) => - CommandTiming( - command, index, snapshot.node_name.theory, - invocations(snapshot, command, offset)) } - val selected = selectedCommands(timings, currentIndex, proofs) - val location = selectedLocation(snapshot, currentIndex, proofs, commandPairs) - currentLabel.setText(location) - tableModel.update(makeRows(selected, location)) - case _ => - currentLabel.setText("No active theory") - tableModel.update(Vector.empty) + } + val selectedIndices = + selectedCommandIndices(scope, currentIndex, proofs, commandPairs.length) + val lineDocument = Line.Document(node.source) + val timings = + selectedIndices.iterator.flatMap { index => + Exn.Interrupt.expose() + commandPairs.lift(index).flatMap { case (command, offset) => + val reports = invocations(snapshot, command, offset) + if (reports.isEmpty) None + else { + val proofContext = proofContexts(index) + Some(CommandTiming( + command, + snapshot.node_name.theory, + proofContext.map(_.name), + proofContext.map(_.start), + lineDocument.position(offset).line + 1, + reports + )) + } + } + }.toVector + val location = + selectedLocation( + snapshot, + scope, + currentIndex, + proofs, + commandPairs, + lineDocument + ) + val navigation = + selectedNavigation( + snapshot, + scope, + currentIndex, + proofs, + commandPairs + ) + val renderState = + makeRenderState( + timings, + scope, + location, + navigation, + indexOptions + ) + renderState -> makeTree(renderState, displayOptions) + } { case (renderState, tree) => + currentRenderState = Some(renderState) + updateTree(tree) } } - private def updateGlobalTimings( + private def startGlobalRefresh( snapshot: Document.Snapshot, - changedNodes: Option[Set[Document.Node.Name]] + indexOptions: IndexOptions, + displayOptions: DisplayOptions ): Unit = { - val domain = - snapshot.version.nodes.names_iterator - .filter(name => name.is_theory && !PIDE.resources.loaded_theory(name)) - .toSet - val refreshNodes = - if (globalTimings.isEmpty) domain - else changedNodes.getOrElse(Set.empty).intersect(domain) - val retained = globalTimings.filter { case (name, _) => domain.contains(name) } - val refreshed = - refreshNodes.iterator.map { name => - val nodeSnapshot = snapshot.switch(name) - val timings = - nodeSnapshot.node.command_iterator().zipWithIndex.flatMap { - case ((command, offset), index) => - val reports = invocations(nodeSnapshot, command, offset) - if (reports.isEmpty) None - else Some(CommandTiming(command, index, name.theory, reports)) - }.toVector - name -> timings - }.toMap - globalTimings = retained ++ refreshed + val previousTimings = globalTimings + val previousIndexes = globalIndexes + val previousIndexOptions = globalIndexOptions + val previousVersion = globalVersion + val dirtyNodes = dirtyGlobalNodes + forkRefresh { + val domain = + snapshot.version.nodes.names_iterator + .filter(name => name.is_theory && !PIDE.resources.loaded_theory(name)) + .toSet + val refreshNodes = + if ( + previousTimings.isEmpty || + (previousVersion.exists(_ != snapshot.version.id) && + dirtyNodes.isEmpty) + ) domain + else dirtyNodes.intersect(domain) + val retained = + previousTimings.filter { case (name, _) => domain.contains(name) } + val refreshed = + refreshNodes.toVector.sortBy(_.theory).iterator.map { name => + Exn.Interrupt.expose() + name -> loadNodeTimings(snapshot.switch(name)) + }.toMap + val timingsByNode = retained ++ refreshed + val reindexAll = + previousIndexes.isEmpty || + !previousIndexOptions.contains(indexOptions) + val retainedIndexes = + if (reindexAll) Map.empty + else { + previousIndexes.filter { case (name, _) => + domain.contains(name) && !refreshNodes.contains(name) + } + } + val reindexNodes = if (reindexAll) domain else refreshNodes + val rebuiltIndexes = + reindexNodes.toVector.sortBy(_.theory).iterator.map { name => + Exn.Interrupt.expose() + name -> makeIndex(timingsByNode.getOrElse(name, Vector.empty), indexOptions) + }.toMap + val indexesByNode = retainedIndexes ++ rebuiltIndexes + val globalIndex = + FineGrainedTimingHierarchy.mergeIndexes( + indexesByNode.toVector.sortBy(_._1.theory).map(_._2) + ) + val renderState = + RenderState( + globalIndex, + ScopeGlobal, + indexOptions.view, + "Global", + NoNavigation + ) + GlobalRefreshResult( + renderState, + makeTree(renderState, displayOptions), + timingsByNode, + indexesByNode, + indexOptions, + domain, + refreshNodes, + snapshot.version.id + ) + } { result => + globalTimings = result.timings + globalIndexes = result.indexes + globalIndexOptions = Some(result.indexOptions) + globalVersion = Some(result.version) + dirtyGlobalNodes = + dirtyGlobalNodes.intersect(result.domain) -- result.refreshedNodes + currentRenderState = Some(result.renderState) + updateTree(result.tree) + } + } + + private def rerenderCurrent(): Unit = { + GUI_Thread.require {} + currentRenderState.foreach { renderState => + val displayOptions = captureDisplayOptions() + forkRefresh { + makeTree(renderState, displayOptions) + } { tree => + updateTree(tree) + } + } + } + + private def forkRefresh[A](work: => A)(install: A => Unit): Unit = { + GUI_Thread.require {} + refreshGeneration += 1L + val generation = refreshGeneration + futureRefresh.change { previous => + previous.foreach(_.cancel()) + Some(Future.fork { + val result = Exn.capture(work) + GUI_Thread.later { + if (generation == refreshGeneration) { + result match { + case Exn.Res(value) => + install(value) + case Exn.Exn(exn) if Exn.is_interrupt(exn) => + case Exn.Exn(exn) => + currentRenderState = None + updateTree(Vector.empty) + Output.error_message( + s"Fine-Grained Timing refresh failed: ${Exn.message(exn)}" + ) + } + } + } + }) + } + } + + private def cancelRefresh(): Unit = { + GUI_Thread.require {} + refreshGeneration += 1L + currentRenderState = None + futureRefresh.change { previous => + previous.foreach(_.cancel()) + None + } + } + + private def loadNodeTimings( + snapshot: Document.Snapshot + ): Vector[CommandTiming] = { + val node = snapshot.node + val commandPairs = node.command_iterator().toVector + val scopeCommands = + commandPairs.map { case (command, offset) => + FineGrainedTimingScope.ScopeCommand( + command.span.name, + offset, + command.length + ) + } + val proofs = FineGrainedTimingScope.partitionNamedProofs(scopeCommands) + val proofContexts = proofContextsByCommand(proofs, commandPairs) + val lineDocument = Line.Document(node.source) + commandPairs.zipWithIndex.flatMap { case ((command, offset), index) => + Exn.Interrupt.expose() + val reports = invocations(snapshot, command, offset) + if (reports.isEmpty) None + else { + val proofContext = proofContexts(index) + Some(CommandTiming( + command, + snapshot.node_name.theory, + proofContext.map(_.name), + proofContext.map(_.start), + lineDocument.position(offset).line + 1, + reports + )) + } + } } private def invocations( @@ -275,143 +616,695 @@ extends JPanel(new BorderLayout) with DefaultFocusComponent { .distinct } - private def selectedCommands( - timings: Vector[CommandTiming], + private def makeRenderState( + commands: Vector[CommandTiming], + scope: String, + location: String, + navigation: NavigationTarget, + options: IndexOptions + ): RenderState = { + val index = makeIndex(commands, options) + RenderState(index, scope, options.view, location, navigation) + } + + private def makeIndex( + commands: Vector[CommandTiming], + options: IndexOptions + ): FineGrainedTimingHierarchy.Index[CommandTiming] = { + val inputs = + commands.zipWithIndex.map { case (command, order) => + FineGrainedTimingHierarchy.Command( + command, + order, + command.theory, + command.proof, + command.invocations + ) + } + FineGrainedTimingHierarchy.build( + inputs, + options.view, + options.nameFilter, + options.showSuccess, + options.showFailure + ) + } + + private def makeTree( + state: RenderState, + options: DisplayOptions + ): Vector[FineGrainedTimingTreeTable.Data] = + state.index.signals.flatMap { signalData => + Exn.Interrupt.expose() + if (groupVisible( + state.view, + signalData.aggregate, + signalData.commands, + options.thresholdMicros + )) { + val rootId = signalRootId(state, signalData.signal) + state.scope match { + case ScopeGlobal => + Vector(groupNode( + signalData.signal, + "Global", + signalData.aggregate, + NoNavigation, + rootId, + options + ) { + makeTheoryNodes( + state, + signalData, + rootId, + options + ) + }) + + case ScopeTheory => + Vector(groupNode( + signalData.signal, + state.location, + signalData.aggregate, + state.navigation, + rootId, + options + ) { + makeProofNodes( + state, + signalData.signal, + signalData.commands, + rootId, + options + ) + }) + + case ScopeProof => + Vector(groupNode( + signalData.signal, + state.location, + signalData.aggregate, + state.navigation, + rootId, + options + ) { + makeCommandNodes( + state, + signalData.signal, + signalData.commands, + rootId, + options + ) + }) + + case ScopeCommand => + signalData.commands + .filter(commandVisible(state.view, _, options.thresholdMicros)) + .flatMap { commandData => + makeDetailNodes( + state, + signalData.signal, + commandData, + "command", + options + ) + } + + case _ => + Vector.empty + } + } + else Vector.empty + } + + private def makeTheoryNodes( + state: RenderState, + signalData: FineGrainedTimingHierarchy.SignalData[CommandTiming], + parentId: String, + options: DisplayOptions + ): Vector[FineGrainedTimingTreeTable.Data] = { + val theoryGroups = + signalData.commands.groupBy(_.command.theory).toVector.flatMap { + case (theory, commands) => + FineGrainedTimingHierarchy.merge(commands.iterator.map(_.aggregate)) + .filter(aggregate => + groupVisible( + state.view, + aggregate, + commands, + options.thresholdMicros + )) + .map(aggregate => (theory, commands, aggregate)) + }.sortBy { case (_, _, aggregate) => + -aggregate.timing.elapsedMicros + } + theoryGroups.map { case (theory, commands, aggregate) => + Exn.Interrupt.expose() + val nodeId = s"$parentId/theory:$theory" + val command = firstCommand(commands) + groupNode( + signalData.signal, + command.node_name.theory_base_name, + aggregate, + TheoryNavigation(command.node_name), + nodeId, + options + ) { + makeProofNodes( + state, + signalData.signal, + commands, + nodeId, + options + ) + } + } + } + + private def makeProofNodes( + state: RenderState, + signal: FineGrainedTimingHierarchy.Signal, + commands: Vector[FineGrainedTimingHierarchy.CommandData[CommandTiming]], + parentId: String, + options: DisplayOptions + ): Vector[FineGrainedTimingTreeTable.Data] = { + val proofGroups = + commands + .groupBy(_.command.proof.getOrElse("")) + .toVector + .flatMap { + case (proof, proofCommands) => + FineGrainedTimingHierarchy.merge( + proofCommands.iterator.map(_.aggregate) + ).filter(aggregate => + groupVisible( + state.view, + aggregate, + proofCommands, + options.thresholdMicros + )) + .map(aggregate => (proof, proofCommands, aggregate)) + } + .sortBy { case (_, proofCommands, _) => + proofCommands.iterator.map(_.command.order).min + } + proofGroups.map { case (proof, proofCommands, aggregate) => + Exn.Interrupt.expose() + val nodeId = s"$parentId/proof:$proof" + groupNode( + signal, + proof, + aggregate, + CommandNavigation(proofStartCommand(proofCommands)), + nodeId, + options + ) { + makeCommandNodes( + state, + signal, + proofCommands, + nodeId, + options + ) + } + } + } + + private def makeCommandNodes( + state: RenderState, + signal: FineGrainedTimingHierarchy.Signal, + commands: Vector[FineGrainedTimingHierarchy.CommandData[CommandTiming]], + parentId: String, + options: DisplayOptions + ): Vector[FineGrainedTimingTreeTable.Data] = + commands.filter(commandVisible(state.view, _, options.thresholdMicros)) + .sortBy(_.command.order) + .map { commandData => + Exn.Interrupt.expose() + val command = commandData.command.value + val nodeId = s"$parentId/command:${command.command.id}" + groupNode( + signal, + commandContext(command), + commandData.aggregate, + CommandNavigation(command.command), + nodeId, + options + ) { + makeDetailNodes( + state, + signal, + commandData, + nodeId, + options + ) + } + } + + private def makeDetailNodes( + state: RenderState, + signal: FineGrainedTimingHierarchy.Signal, + commandData: FineGrainedTimingHierarchy.CommandData[CommandTiming], + parentId: String, + options: DisplayOptions + ): Vector[FineGrainedTimingTreeTable.Data] = { + val command = commandData.command.value + state.view match { + case FineGrainedTimingHierarchy.Calls => + commandData.invocations + .filter(visible => + invocationVisible(visible.invocation, options.thresholdMicros)) + .sortBy(visible => + -visible.invocation.timing.map(_.elapsedMicros).getOrElse(0L)) + .map { visible => + val invocation = visible.invocation + val location = + detailLocation( + state, + command, + invocation.id.toString + ) + FineGrainedTimingTreeTable.Data( + DetailRow( + CommandNavigation(command.command), + s"$parentId/invocation:${visible.index}:${invocation.id}", + invocationValues( + location, + invocation, + options.timingDigits + ) + ) + ) + } + + case FineGrainedTimingHierarchy.Aggregate => + if ( + commandData.aggregate.timing.elapsedMicros.toDouble >= + options.thresholdMicros + ) { + val location = detailLocation(state, command, "Sample") + Vector( + FineGrainedTimingTreeTable.Data( + DetailRow( + CommandNavigation(command.command), + s"$parentId/sample:${signal.name}:${signal.success}", + aggregateValues( + location, + signal, + commandData.aggregate, + options.timingDigits + ) + ) + ) + ) + } + else Vector.empty + } + } + + private def groupNode( + signal: FineGrainedTimingHierarchy.Signal, + location: String, + aggregate: FineGrainedTiming.Aggregate, + navigation: NavigationTarget, + nodeId: String, + options: DisplayOptions + )( + children: => Vector[FineGrainedTimingTreeTable.Data] + ): FineGrainedTimingTreeTable.Data = { + val expanded = options.expandedNodes.contains(nodeId) + FineGrainedTimingTreeTable.Data( + GroupRow( + navigation, + nodeId, + aggregateValues( + location, + signal, + aggregate, + options.timingDigits + ) + ), + children = if (expanded) children else Vector.empty, + unloaded = !expanded + ) + } + + private def invocationValues( + location: String, + invocation: FineGrainedTiming.Invocation, + digits: Int + ): Vector[String] = { + val sampleCount = invocation.samples.iterator.map(_.aggregate.count).sum + val elapsed = + invocation.timing.map(timing => formatMicros(timing.elapsedMicros, digits)) + Vector( + location, + invocation.method, + if (invocation.success) "success" else "failure", + sampleCount.toString, + elapsed.getOrElse(""), + "", + "", + "", + "", + "", + "" + ) + } + + private def aggregateValues( + location: String, + signal: FineGrainedTimingHierarchy.Signal, + aggregate: FineGrainedTiming.Aggregate, + digits: Int + ): Vector[String] = + Vector( + location, + signal.name, + if (signal.success) "success" else "failure", + aggregate.count.toString, + formatMicros(aggregate.timing.elapsedMicros, digits), + formatMicros(aggregate.averageElapsedMicros, digits), + formatMicros(aggregate.percentileElapsedMicros(0.50), digits), + formatMicros(aggregate.percentileElapsedMicros(0.90), digits), + formatMicros(aggregate.percentileElapsedMicros(0.99), digits), + formatMicros(aggregate.minElapsedMicros, digits), + formatMicros(aggregate.maxElapsedMicros, digits) + ) + + private def firstCommand( + commands: Vector[FineGrainedTimingHierarchy.CommandData[CommandTiming]] + ): Command = + commands.minBy(_.command.order).command.value.command + + private def proofStartCommand( + commands: Vector[FineGrainedTimingHierarchy.CommandData[CommandTiming]] + ): Command = + commands.iterator.flatMap(_.command.value.proofStart).nextOption + .getOrElse(firstCommand(commands)) + + private def invocationVisible( + invocation: FineGrainedTiming.Invocation, + thresholdMicros: Double + ): Boolean = + invocation.timing.forall( + _.elapsedMicros.toDouble >= thresholdMicros + ) + + private def commandVisible( + view: FineGrainedTimingHierarchy.View, + command: FineGrainedTimingHierarchy.CommandData[CommandTiming], + thresholdMicros: Double + ): Boolean = + view match { + case FineGrainedTimingHierarchy.Calls => + command.invocations.exists(visible => + invocationVisible(visible.invocation, thresholdMicros)) + case FineGrainedTimingHierarchy.Aggregate => + command.aggregate.timing.elapsedMicros.toDouble >= thresholdMicros + } + + private def groupVisible( + view: FineGrainedTimingHierarchy.View, + aggregate: FineGrainedTiming.Aggregate, + commands: Vector[ + FineGrainedTimingHierarchy.CommandData[CommandTiming] + ], + thresholdMicros: Double + ): Boolean = + view match { + case FineGrainedTimingHierarchy.Calls => + commands.exists(commandVisible(view, _, thresholdMicros)) + case FineGrainedTimingHierarchy.Aggregate => + aggregate.timing.elapsedMicros.toDouble >= thresholdMicros + } + + private def signalRootId( + state: RenderState, + signal: FineGrainedTimingHierarchy.Signal + ): String = { + val location = if (state.scope == ScopeGlobal) "global" else state.location + s"signal:${signal.name}:${signal.success}/scope:${state.scope}/$location" + } + + private def selectedCommandIndices( + scope: String, currentIndex: Option[Int], - proofs: IndexedSeq[FineGrainedTimingScope.NamedProof] - ): Vector[CommandTiming] = - scopeSelector.getSelectedItem.toString match { + proofs: IndexedSeq[FineGrainedTimingScope.NamedProof], + commandCount: Int + ): Vector[Int] = + scope match { case ScopeCommand => - currentIndex.flatMap(timings.lift).toVector + currentIndex.toVector case ScopeProof => currentIndex .flatMap(index => FineGrainedTimingScope.namedProofAt(proofs, index)) - .map(proof => timings.slice(proof.startIndex, proof.endIndex + 1)) + .map(proof => (proof.startIndex to proof.endIndex).toVector) .getOrElse(Vector.empty) - case ScopeTheory => - timings - case ScopeGlobal => - timings + case ScopeTheory | ScopeGlobal => + (0 until commandCount).toVector case _ => Vector.empty } private def selectedLocation( snapshot: Document.Snapshot, + scope: String, currentIndex: Option[Int], proofs: IndexedSeq[FineGrainedTimingScope.NamedProof], - commands: Vector[(Command, Int)] + commands: Vector[(Command, Int)], + lineDocument: Line.Document ): String = - scopeSelector.getSelectedItem.toString match { + scope match { case ScopeCommand => currentIndex .flatMap(commands.lift) - .map { case (command, _) => s"Command: ${command.span.name}" } - .getOrElse("Command: none") + .map { case (command, offset) => + val line = lineDocument.position(offset).line + 1 + s"${command.span.name}:$line" + } + .getOrElse("none") case ScopeProof => currentIndex .flatMap(index => FineGrainedTimingScope.namedProofAt(proofs, index)) .flatMap(proof => commands.lift(proof.startIndex)) - .map { case (command, _) => s"Proof: ${proofName(command)}" } - .getOrElse("Proof: none") + .map { case (command, _) => proofName(command) } + .getOrElse("none") case ScopeTheory => - s"Theory: ${snapshot.node_name.theory}" + snapshot.node_name.theory_base_name case ScopeGlobal => "Global" case _ => "" } - private def makeRows( - commands: Vector[CommandTiming], - location: String - ): Vector[TimingRow] = { - val threshold = thresholdMicros - val successEnabled = showSuccess.isSelected - val failureEnabled = showFailure.isSelected - if (viewSelector.getSelectedItem.toString == CallsView) { - commands.iterator - .flatMap(command => - command.invocations.iterator.map(invocation => - InvocationRow( - command.command, - if (scopeSelector.getSelectedItem.toString == ScopeGlobal) - s"${command.theory}: ${command.command.span.name}" - else location, - invocation))) - .filter(row => if (row.invocation.success) successEnabled else failureEnabled) - .filter(row => - row.invocation.timing.forall(_.elapsedMicros.toDouble >= threshold)) - .toVector - .sortBy(row => -row.invocation.timing.map(_.elapsedMicros).getOrElse(0L)) - } else { - val merged = - mutable.LinkedHashMap.empty[ - FineGrainedTiming.SampleKey, - (FineGrainedTiming.Aggregate, Command) - ] - commands.foreach { command => - FineGrainedTiming.aggregate(command.invocations).foreach { case (key, aggregate) => - merged.updateWith(key) { - case Some((existing, firstCommand)) => - Some((existing + aggregate, firstCommand)) - case None => - Some((aggregate, command.command)) - } + private def selectedNavigation( + snapshot: Document.Snapshot, + scope: String, + currentIndex: Option[Int], + proofs: IndexedSeq[FineGrainedTimingScope.NamedProof], + commands: Vector[(Command, Int)] + ): NavigationTarget = + scope match { + case ScopeCommand => + currentIndex.flatMap(commands.lift) + .map { case (command, _) => CommandNavigation(command) } + .getOrElse(NoNavigation) + case ScopeProof => + currentIndex + .flatMap(index => FineGrainedTimingScope.namedProofAt(proofs, index)) + .flatMap(proof => commands.lift(proof.startIndex)) + .map { case (command, _) => CommandNavigation(command) } + .getOrElse(NoNavigation) + case ScopeTheory => + TheoryNavigation(snapshot.node_name) + case _ => + NoNavigation + } + + private def proofName(command: Command): String = + FineGrainedTimingScope.proofName(command.source, command.span.name) + + private def proofContextsByCommand( + proofs: IndexedSeq[FineGrainedTimingScope.NamedProof], + commands: Vector[(Command, Int)] + ): Vector[Option[ProofContext]] = { + val result = Array.fill[Option[ProofContext]](commands.length)(None) + proofs.foreach { proof => + val context = + commands.lift(proof.startIndex).map { case (command, _) => + ProofContext(proofName(command), command) } + var index = proof.startIndex + while (index <= proof.endIndex && index < result.length) { + result(index) = context + index += 1 } - merged.iterator - .map { case (key, (aggregate, command)) => - AggregateRow(command, location, key, aggregate) - } - .filter(row => if (row.key.success) successEnabled else failureEnabled) - .filter(row => categoryMatches(row.key.name)) - .filter(_.aggregate.timing.elapsedMicros.toDouble >= threshold) - .toVector - .sortBy(row => -row.aggregate.timing.elapsedMicros) } + result.toVector } - private def categoryMatches(name: String): Boolean = { - val selected = categorySelector.getSelectedItem.toString - selected == "all" || category(name) == selected + private def commandContext(command: CommandTiming): String = + s"${command.command.span.name}:${command.line}" + + private def detailLocation( + state: RenderState, + command: CommandTiming, + detail: String + ): String = + if (state.scope == ScopeCommand) + s"${commandContext(command)} / $detail" + else detail + + private def captureIndexOptions(): IndexOptions = { + GUI_Thread.require {} + IndexOptions( + if (viewSelector.getSelectedItem.toString == CallsView) + FineGrainedTimingHierarchy.Calls + else FineGrainedTimingHierarchy.Aggregate, + filterField.getText, + showSuccess.isSelected, + showFailure.isSelected + ) } - private def category(name: String): String = { - val lower = name.toLowerCase - if (lower.contains("clarsimp")) "clarsimp" - else if (lower.contains("seplog") || lower.contains("aentails")) "seplog" - else if (lower.contains("transaction")) "transaction" - else if (lower.contains("call")) "call" - else if (lower.contains("setup") || lower.contains("instantiation")) "setup" - else if (lower.contains("step")) "step" - else if (lower.contains("branch")) "branch" - else "other" + private def captureDisplayOptions(): DisplayOptions = { + GUI_Thread.require {} + DisplayOptions(expandedNodes, timingDigits, thresholdMicros) } - private def proofName(command: Command): String = { - val pattern = - """(?s)^\s*(?:lemma|theorem|corollary|proposition|schematic_goal)\s+([A-Za-z0-9_']+)""".r - pattern.findFirstMatchIn(command.source).map(_.group(1)) - .getOrElse(command.span.name) + private def updateTree( + data: Vector[FineGrainedTimingTreeTable.Data] + ): Unit = { + GUI_Thread.require {} + val selectedId = + table.valueAtRow(table.getSelectedRow).collect { + case row: TimingRow => row.nodeId + } + restoringTreeExpansion = true + try { + treeModel.update(data) + val paths = treeModel.paths + paths.foreach { + case (group: GroupRow, path) + if expandedNodes.contains(group.nodeId) => + table.tree.expandPath(path) + case _ => + } + selectedId.foreach { nodeId => + paths.collectFirst { + case (row: TimingRow, path) if row.nodeId == nodeId => path + }.foreach(table.tree.setSelectionPath) + } + table.refreshRows() + } finally { + restoringTreeExpansion = false + } + } + + private def loadVisibleColumnIds(): Vector[String] = { + val defaults = ( + "location" +: "name" +: + columnDescriptors.iterator + .filter(_.defaultVisible) + .map(_.id) + .toVector + ).distinct + val stored = jEdit.getProperty(VisibleColumnsProperty, "").split(",") + .iterator.map(_.trim).filter(columnIndex.contains).toVector.distinct + if (stored.nonEmpty) ("location" +: "name" +: stored).distinct else defaults + } + + private def applyVisibleColumns(): Unit = { + val model = table.getColumnModel + while (model.getColumnCount > 0) model.removeColumn(model.getColumn(0)) + visibleColumnIds.foreach { id => + val column = new TableColumn(columnIndex(id)) + column.setHeaderValue(columnDescriptors(columnIndex(id)).title) + model.addColumn(column) + } + } + + private def showColumnDialog(): Unit = { + GUI_Thread.require {} + val checks = columnDescriptors.map { descriptor => + val check = new JCheckBox( + descriptor.title, + visibleColumnIds.contains(descriptor.id) + ) + check.setEnabled(descriptor.id != "name" && descriptor.id != "location") + descriptor -> check + } + val panel = new JPanel(new GridLayout(0, 2, 8, 2)) + checks.foreach { case (_, check) => panel.add(check) } + val result = JOptionPane.showConfirmDialog( + this, + panel, + "Visible Timing Columns", + JOptionPane.OK_CANCEL_OPTION, + JOptionPane.PLAIN_MESSAGE + ) + if (result == JOptionPane.OK_OPTION) { + val selected = + checks.iterator.collect { + case (descriptor, check) if check.isSelected => descriptor.id + }.toVector + visibleColumnIds = ("location" +: "name" +: selected).distinct + if (visibleColumnIds.nonEmpty) { + jEdit.setProperty(VisibleColumnsProperty, visibleColumnIds.mkString(",")) + applyVisibleColumns() + } + } } private def thresholdMicros: Double = try math.max(0.0, thresholdField.getText.trim.toDouble) * 1000000.0 catch { case _: NumberFormatException => 0.0 } - private def formatMicros(micros: Long): String = - f"${micros.toDouble / 1000000.0}%.6fs" + private def loadTimingDigits(): Int = { + val stored = jEdit.getProperty( + TimingDigitsProperty, + DefaultTimingDigits.toString + ) + try math.max(MinTimingDigits, math.min(MaxTimingDigits, stored.trim.toInt)) + catch { case _: NumberFormatException => DefaultTimingDigits } + } - private def formatMicros(micros: Double): String = - f"${micros / 1000000.0}%.6fs" + private def updateTimingDigits(): Unit = { + val value = + try math.max( + MinTimingDigits, + math.min(MaxTimingDigits, timingDigitsField.getText.trim.toInt) + ) + catch { case _: NumberFormatException => timingDigits } + timingDigits = value + timingDigitsField.setText(value.toString) + jEdit.setProperty(TimingDigitsProperty, value.toString) + rerenderCurrent() + } + + private def formatMicros(micros: Long, digits: Int): String = + String.format( + Locale.ROOT, + "%." + digits + "fs", + java.lang.Double.valueOf(micros.toDouble / 1000000.0) + ) + + private def formatMicros(micros: Double, digits: Int): String = + String.format( + Locale.ROOT, + "%." + digits + "fs", + java.lang.Double.valueOf(micros / 1000000.0) + ) private val main = Session.Consumer[Any](getClass.getName) { case changed: Session.Commands_Changed => GUI_Thread.later { refresh(Some(changed.nodes)) } case Session.Caret_Focus => - GUI_Thread.later { refresh() } + GUI_Thread.later { + if (scopeSelector.getSelectedItem.toString != ScopeGlobal) refresh() + } case _ => } @@ -425,6 +1318,12 @@ extends JPanel(new BorderLayout) with DefaultFocusComponent { override def removeNotify(): Unit = { PIDE.session.caret_focus -= main PIDE.session.commands_changed -= main + cancelRefresh() + globalTimings = Map.empty + globalIndexes = Map.empty + globalIndexOptions = None + globalVersion = None + dirtyGlobalNodes = Set.empty super.removeNotify() } diff --git a/Fine_Grained_Timing/src/FineGrainedTimingHierarchy.scala b/Fine_Grained_Timing/src/FineGrainedTimingHierarchy.scala new file mode 100644 index 00000000..c4658373 --- /dev/null +++ b/Fine_Grained_Timing/src/FineGrainedTimingHierarchy.scala @@ -0,0 +1,164 @@ +/* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT */ + +import scala.collection.mutable + +import isabelle.Exn + +object FineGrainedTimingHierarchy { + sealed trait View + case object Calls extends View + case object Aggregate extends View + + final case class Signal(name: String, success: Boolean) + + final case class Command[A]( + value: A, + order: Int, + theory: String, + proof: Option[String], + invocations: Vector[FineGrainedTiming.Invocation] + ) + + final case class VisibleInvocation( + index: Int, + invocation: FineGrainedTiming.Invocation + ) + + final case class CommandData[A]( + command: Command[A], + aggregate: FineGrainedTiming.Aggregate, + invocations: Vector[VisibleInvocation] + ) + + final case class SignalData[A]( + signal: Signal, + aggregate: FineGrainedTiming.Aggregate, + commands: Vector[CommandData[A]] + ) + + final case class Index[A](signals: Vector[SignalData[A]]) + + def build[A]( + commands: Vector[Command[A]], + view: View, + nameFilter: String, + showSuccess: Boolean, + showFailure: Boolean + ): Index[A] = { + val bySignal = + mutable.LinkedHashMap.empty[Signal, mutable.ArrayBuffer[CommandData[A]]] + val normalizedFilter = nameFilter.trim.toLowerCase(java.util.Locale.ROOT) + + def signalEnabled(signal: Signal): Boolean = + (if (signal.success) showSuccess else showFailure) && + (normalizedFilter.isEmpty || + signal.name.toLowerCase(java.util.Locale.ROOT) + .contains(normalizedFilter)) + + def add(signal: Signal, data: CommandData[A]): Unit = + if (signalEnabled(signal)) { + bySignal.getOrElseUpdate(signal, mutable.ArrayBuffer.empty) += data + } + + commands.foreach { command => + Exn.Interrupt.expose() + view match { + case Calls => + command.invocations.zipWithIndex + .groupBy { case (invocation, _) => + Signal(invocation.method, invocation.success) + } + .foreach { case (signal, indexedInvocations) => + val aggregate = + indexedInvocations.iterator + .flatMap { case (invocation, _) => + invocation.samples.iterator.map(_.aggregate) + } + .reduceOption(_ + _) + .getOrElse(EmptyAggregate) + add( + signal, + CommandData( + command, + aggregate, + indexedInvocations.iterator.map { + case (invocation, index) => + VisibleInvocation(index, invocation) + }.toVector + ) + ) + } + + case Aggregate => + FineGrainedTiming.aggregate(command.invocations) + .foreach { case (key, aggregate) => + add( + Signal(key.name, key.success), + CommandData( + command, + aggregate, + Vector.empty + ) + ) + } + } + } + + val signals = + bySignal.iterator.flatMap { case (signal, commandBuffer) => + val signalCommands = commandBuffer.toVector.sortBy(_.command.order) + merge(signalCommands.iterator.map(_.aggregate)) + .map(SignalData(signal, _, signalCommands)) + }.toVector.sortBy(data => -data.aggregate.timing.elapsedMicros) + + Index(signals) + } + + def mergeIndexes[A](indexes: Vector[Index[A]]): Index[A] = { + val bySignal = + mutable.LinkedHashMap.empty[ + Signal, + (FineGrainedTiming.Aggregate, mutable.ArrayBuffer[CommandData[A]]) + ] + indexes.foreach { index => + index.signals.foreach { signalData => + bySignal.get(signalData.signal) match { + case Some((aggregate, commands)) => + commands ++= signalData.commands + bySignal.update( + signalData.signal, + (aggregate + signalData.aggregate, commands) + ) + case None => + bySignal.update( + signalData.signal, + ( + signalData.aggregate, + mutable.ArrayBuffer.from(signalData.commands) + ) + ) + } + } + } + Index( + bySignal.iterator.map { case (signal, (aggregate, commands)) => + SignalData(signal, aggregate, commands.toVector) + }.toVector.sortBy(data => -data.aggregate.timing.elapsedMicros) + ) + } + + def merge( + aggregates: Iterator[FineGrainedTiming.Aggregate] + ): Option[FineGrainedTiming.Aggregate] = + aggregates.reduceOption(_ + _) + + private val EmptyAggregate = + FineGrainedTiming.Aggregate( + count = 0L, + timing = FineGrainedTiming.Timing(0L, 0L, 0L), + minElapsedMicros = 0L, + maxElapsedMicros = 0L, + histogram = Map.empty + ) +} diff --git a/Fine_Grained_Timing/src/FineGrainedTimingScope.scala b/Fine_Grained_Timing/src/FineGrainedTimingScope.scala index 219c71bc..2777efbc 100644 --- a/Fine_Grained_Timing/src/FineGrainedTimingScope.scala +++ b/Fine_Grained_Timing/src/FineGrainedTimingScope.scala @@ -14,6 +14,13 @@ object FineGrainedTimingScope { private val NamedProofStarters: Set[String] = Set("lemma", "theorem", "corollary", "proposition", "schematic_goal") + private val ProofNamePattern = + """(?s)^\s*(?:lemma|theorem|corollary|proposition|schematic_goal)\s+([A-Za-z0-9_'.]+)""".r + + def proofName(source: String, fallback: String): String = + ProofNamePattern.findFirstMatchIn(source).map(_.group(1)) + .getOrElse(fallback) + def partitionNamedProofs(commands: IndexedSeq[ScopeCommand]): IndexedSeq[NamedProof] = { val result = Vector.newBuilder[NamedProof] var i = 0 diff --git a/Fine_Grained_Timing/src/FineGrainedTimingTreeTable.scala b/Fine_Grained_Timing/src/FineGrainedTimingTreeTable.scala new file mode 100644 index 00000000..4bf1a3e7 --- /dev/null +++ b/Fine_Grained_Timing/src/FineGrainedTimingTreeTable.scala @@ -0,0 +1,375 @@ +/* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT */ + +import java.awt.{Component, Graphics} +import java.awt.event.{KeyAdapter, KeyEvent, MouseEvent} +import java.util.EventObject +import javax.swing.{ + AbstractCellEditor, + JTable, + JTree, + ListSelectionModel +} +import javax.swing.event.{ + ListSelectionEvent, + ListSelectionListener, + TreeExpansionEvent, + TreeExpansionListener, + TreeModelEvent, + TreeModelListener, + TreeSelectionEvent, + TreeSelectionListener +} +import javax.swing.table.{ + AbstractTableModel, + TableCellEditor, + TableCellRenderer +} +import javax.swing.tree.{ + DefaultMutableTreeNode, + DefaultTreeCellRenderer, + DefaultTreeModel, + TreePath +} + +object FineGrainedTimingTreeTable { + sealed trait TreeColumn + + case object Loading + + final case class Data( + value: AnyRef, + children: Vector[Data] = Vector.empty, + unloaded: Boolean = false + ) + + trait Columns { + def count: Int + def name(column: Int): String + def columnClass(column: Int): Class[?] + def valueAt(value: AnyRef, column: Int): AnyRef + } + + private final class Node(value: AnyRef) + extends DefaultMutableTreeNode(value) + + final class Model(val columns: Columns) + extends DefaultTreeModel(new Node(null)) { + private def rootNode: Node = getRoot.asInstanceOf[Node] + + private def makeNode(data: Data): Node = { + val node = new Node(data.value) + data.children.foreach(child => node.add(makeNode(child))) + if (data.unloaded) node.add(new Node(Loading)) + node + } + + def update(data: Vector[Data]): Unit = { + rootNode.removeAllChildren() + data.foreach(entry => rootNode.add(makeNode(entry))) + reload(rootNode) + } + + def value(node: AnyRef): AnyRef = + node.asInstanceOf[Node].getUserObject + + def valueAt(node: AnyRef, column: Int): AnyRef = + columns.valueAt(value(node), column) + + def paths: Vector[(AnyRef, TreePath)] = { + val result = Vector.newBuilder[(AnyRef, TreePath)] + val nodes = rootNode.preorderEnumeration() + while (nodes.hasMoreElements) { + val node = nodes.nextElement().asInstanceOf[Node] + if (node ne rootNode) { + val path = + new TreePath(node.getPath.map(_.asInstanceOf[AnyRef])) + result += ((node.getUserObject, path)) + } + } + result.result() + } + } + + final class Table(val treeModel: Model, val treeColumn: Int) + extends JTable { + private final class TreeRenderer + extends JTree(treeModel) with TableCellRenderer { + private var visibleRow = 0 + + setRootVisible(false) + setShowsRootHandles(true) + setCellRenderer(new DefaultTreeCellRenderer { + setOpenIcon(null) + setClosedIcon(null) + setLeafIcon(null) + + override def getTreeCellRendererComponent( + tree: JTree, + value: AnyRef, + selected: Boolean, + expanded: Boolean, + leaf: Boolean, + row: Int, + hasFocus: Boolean + ): Component = { + val component = + super.getTreeCellRendererComponent( + tree, + value, + selected, + expanded, + leaf, + row, + hasFocus + ) + val text = + Table.this.treeModel.value(value) match { + case Loading => "Loading..." + case entry => + Table.this.treeModel.columns + .valueAt(entry, treeColumn).toString + } + setText(text) + component + } + }) + + override def getTableCellRendererComponent( + table: JTable, + value: AnyRef, + selected: Boolean, + hasFocus: Boolean, + row: Int, + column: Int + ): Component = { + val _ = (value, hasFocus, column) + visibleRow = row + setBackground( + if (selected) table.getSelectionBackground + else table.getBackground + ) + this + } + + override def setBounds( + x: Int, + y: Int, + width: Int, + height: Int + ): Unit = { + val _ = (y, height) + super.setBounds(x, 0, width, Table.this.getHeight) + } + + override def paint(graphics: Graphics): Unit = { + graphics.translate(0, -visibleRow * getRowHeight) + super.paint(graphics) + } + } + + private final class Adapter(tree: JTree) + extends AbstractTableModel { + private def refreshRows(): Unit = fireTableDataChanged() + + tree.addTreeExpansionListener(new TreeExpansionListener { + override def treeExpanded(event: TreeExpansionEvent): Unit = { + val _ = event + refreshRows() + } + + override def treeCollapsed(event: TreeExpansionEvent): Unit = { + val _ = event + refreshRows() + } + }) + + treeModel.addTreeModelListener(new TreeModelListener { + override def treeNodesChanged(event: TreeModelEvent): Unit = { + val _ = event + refreshRows() + } + + override def treeNodesInserted(event: TreeModelEvent): Unit = { + val _ = event + refreshRows() + } + + override def treeNodesRemoved(event: TreeModelEvent): Unit = { + val _ = event + refreshRows() + } + + override def treeStructureChanged(event: TreeModelEvent): Unit = { + val _ = event + refreshRows() + } + }) + + override def getColumnCount: Int = treeModel.columns.count + override def getColumnName(column: Int): String = + treeModel.columns.name(column) + override def getColumnClass(column: Int): Class[?] = + treeModel.columns.columnClass(column) + override def getRowCount: Int = tree.getRowCount + override def isCellEditable(row: Int, column: Int): Boolean = { + val _ = row + column == treeColumn + } + + override def getValueAt(row: Int, column: Int): AnyRef = { + val path = tree.getPathForRow(row) + if (path == null) "" + else treeModel.valueAt(path.getLastPathComponent, column) + } + } + + private final class TreeEditor(tree: JTree) + extends AbstractCellEditor with TableCellEditor { + override def getTableCellEditorComponent( + table: JTable, + value: AnyRef, + selected: Boolean, + row: Int, + column: Int + ): Component = { + val _ = (table, value, selected, row, column) + tree + } + + override def getCellEditorValue: AnyRef = null + + override def isCellEditable(event: EventObject): Boolean = { + event match { + case mouse: MouseEvent => + val viewColumn = columnAtPoint(mouse.getPoint) + if ( + viewColumn >= 0 && + convertColumnIndexToModel(viewColumn) == treeColumn + ) { + val cell = getCellRect(0, viewColumn, true) + val forwarded = + new MouseEvent( + tree, + mouse.getID, + mouse.getWhen, + mouse.getModifiersEx, + mouse.getX - cell.x, + mouse.getY, + mouse.getClickCount, + mouse.isPopupTrigger, + mouse.getButton + ) + tree.dispatchEvent(forwarded) + } + case _ => + } + false + } + } + + private val treeRenderer = new TreeRenderer + private val adapter = new Adapter(treeRenderer) + private var synchronizingSelection = false + + setModel(adapter) + setDefaultRenderer(classOf[TreeColumn], treeRenderer) + setDefaultEditor(classOf[TreeColumn], new TreeEditor(treeRenderer)) + setSelectionMode(ListSelectionModel.SINGLE_SELECTION) + treeRenderer.setRowHeight(getRowHeight) + + getSelectionModel.addListSelectionListener(new ListSelectionListener { + override def valueChanged(event: ListSelectionEvent): Unit = { + if (!event.getValueIsAdjusting && !synchronizingSelection) { + synchronizingSelection = true + try { + val row = getSelectedRow + if (row >= 0) treeRenderer.setSelectionRow(row) + else treeRenderer.clearSelection() + } finally { + synchronizingSelection = false + } + } + } + }) + + treeRenderer.addTreeSelectionListener(new TreeSelectionListener { + override def valueChanged(event: TreeSelectionEvent): Unit = { + val _ = event + if (!synchronizingSelection) { + synchronizingSelection = true + try { + val rows = treeRenderer.getSelectionRows + if (rows == null || rows.isEmpty) clearSelection() + else setRowSelectionInterval(rows.head, rows.head) + } finally { + synchronizingSelection = false + } + } + } + }) + + addKeyListener(new KeyAdapter { + private def selectPath(path: TreePath): Unit = { + val row = treeRenderer.getRowForPath(path) + if (row >= 0) { + setRowSelectionInterval(row, row) + scrollRectToVisible(getCellRect(row, 0, true)) + } + } + + override def keyPressed(event: KeyEvent): Unit = { + val path = treeRenderer.getSelectionPath + if (path != null) { + event.getKeyCode match { + case KeyEvent.VK_RIGHT => + if (!treeModel.isLeaf(path.getLastPathComponent)) { + if (!treeRenderer.isExpanded(path)) { + treeRenderer.expandPath(path) + } + else { + val nextRow = treeRenderer.getRowForPath(path) + 1 + Option(treeRenderer.getPathForRow(nextRow)) + .foreach(selectPath) + } + event.consume() + } + case KeyEvent.VK_LEFT => + if (treeRenderer.isExpanded(path)) { + treeRenderer.collapsePath(path) + event.consume() + } + else { + val parent = path.getParentPath + if ( + parent != null && + parent.getParentPath != null + ) { + selectPath(parent) + event.consume() + } + } + case _ => + } + } + } + }) + + override def getEditingRow: Int = { + val column = getEditingColumn + if ( + column >= 0 && + convertColumnIndexToModel(column) == treeColumn + ) -1 + else super.getEditingRow + } + + def tree: JTree = treeRenderer + + def valueAtRow(row: Int): Option[AnyRef] = + Option(treeRenderer.getPathForRow(row)) + .map(path => treeModel.value(path.getLastPathComponent)) + + def refreshRows(): Unit = adapter.fireTableDataChanged() + } +} diff --git a/Fine_Grained_Timing/test/FineGrainedTimingHierarchyTest.scala b/Fine_Grained_Timing/test/FineGrainedTimingHierarchyTest.scala new file mode 100644 index 00000000..851a330d --- /dev/null +++ b/Fine_Grained_Timing/test/FineGrainedTimingHierarchyTest.scala @@ -0,0 +1,172 @@ +/* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT */ + +object FineGrainedTimingHierarchyTest { + private def requireThat(condition: Boolean, message: String): Unit = { + if (!condition) throw new RuntimeException(message) + } + + private def aggregate( + count: Long, + elapsed: Long + ): FineGrainedTiming.Aggregate = + FineGrainedTiming.Aggregate( + count, + FineGrainedTiming.Timing(elapsed, elapsed / 2, 0L), + elapsed, + elapsed, + Map(0 -> count) + ) + + private def invocation( + id: Long, + method: String, + success: Boolean, + elapsed: Long, + samples: (String, Boolean, FineGrainedTiming.Aggregate)* + ): FineGrainedTiming.Invocation = + FineGrainedTiming.Invocation( + id, + method, + success, + Some(FineGrainedTiming.Timing(elapsed, elapsed / 2, 0L)), + samples.map { case (name, sampleSuccess, sampleAggregate) => + FineGrainedTiming.Sample(name, sampleSuccess, sampleAggregate) + }.toVector + ) + + private val commands = + Vector( + FineGrainedTimingHierarchy.Command( + "command-1", + order = 0, + theory = "T1", + proof = Some("p1"), + Vector( + invocation( + 1L, + "profile", + success = true, + elapsed = 10L, + ("branch", true, aggregate(2L, 8L)) + ), + invocation( + 2L, + "profile", + success = false, + elapsed = 2L, + ("branch", false, aggregate(1L, 2L)) + ) + ) + ), + FineGrainedTimingHierarchy.Command( + "command-2", + order = 1, + theory = "T2", + proof = Some("p2"), + Vector( + invocation( + 3L, + "profile", + success = true, + elapsed = 20L, + ("branch", true, aggregate(3L, 12L)) + ) + ) + ), + FineGrainedTimingHierarchy.Command( + "command-3", + order = 2, + theory = "T3", + proof = Some("p3"), + Vector( + invocation( + 4L, + "empty_profile", + success = true, + elapsed = 30L + ) + ) + ) + ) + + private def testAggregateIndex(): Unit = { + val index = + FineGrainedTimingHierarchy.build( + commands, + FineGrainedTimingHierarchy.Aggregate, + nameFilter = "bran", + showSuccess = true, + showFailure = false + ) + requireThat(index.signals.length == 1, s"unexpected signals: ${index.signals}") + val signal = index.signals.head + requireThat(signal.signal == FineGrainedTimingHierarchy.Signal("branch", true), + s"unexpected signal ${signal.signal}") + requireThat(signal.aggregate.count == 5L, + s"aggregate count should merge commands: ${signal.aggregate.count}") + requireThat(signal.commands.map(_.command.theory) == Vector("T1", "T2"), + s"command order was not retained: ${signal.commands}") + } + + private def testCallsAndIndexMerge(): Unit = { + val index = + FineGrainedTimingHierarchy.build( + commands, + FineGrainedTimingHierarchy.Calls, + nameFilter = "", + showSuccess = true, + showFailure = true + ) + val signal = + index.signals.find(_.signal == + FineGrainedTimingHierarchy.Signal("profile", true)) + .getOrElse(sys.error(s"missing profile signal: ${index.signals}")) + requireThat(signal.commands.length == 2, + s"both successful commands should remain indexed: ${signal.commands}") + requireThat(signal.commands.forall(_.invocations.length == 1), + s"call details were not retained: ${signal.commands}") + val empty = + index.signals.find(_.signal == + FineGrainedTimingHierarchy.Signal("empty_profile", true)) + .getOrElse(sys.error(s"missing zero-sample call: ${index.signals}")) + requireThat(empty.aggregate.count == 0L && empty.commands.head.invocations.length == 1, + s"zero-sample call was not indexed: $empty") + + val left = + FineGrainedTimingHierarchy.build( + commands.take(1), + FineGrainedTimingHierarchy.Calls, + nameFilter = "", + showSuccess = true, + showFailure = true + ) + val right = + FineGrainedTimingHierarchy.build( + commands.drop(1), + FineGrainedTimingHierarchy.Calls, + nameFilter = "", + showSuccess = true, + showFailure = true + ) + val merged = FineGrainedTimingHierarchy.mergeIndexes(Vector(left, right)) + requireThat(merged.signals.map(_.signal).toSet == + index.signals.map(_.signal).toSet, + s"merged index lost signals: $merged") + val mergedProfile = + merged.signals.find(_.signal == + FineGrainedTimingHierarchy.Signal("profile", true)) + .getOrElse(sys.error(s"merged profile signal is missing: $merged")) + requireThat( + mergedProfile.aggregate.count == signal.aggregate.count && + mergedProfile.commands.length == signal.commands.length, + s"merged index did not combine matching signals: $mergedProfile" + ) + } + + def main(_args: Array[String]): Unit = { + testAggregateIndex() + testCallsAndIndexMerge() + println("FineGrainedTimingHierarchyTest: all tests passed") + } +} diff --git a/Fine_Grained_Timing/test/FineGrainedTimingScopeTest.scala b/Fine_Grained_Timing/test/FineGrainedTimingScopeTest.scala index 2f3afadc..0370c561 100644 --- a/Fine_Grained_Timing/test/FineGrainedTimingScopeTest.scala +++ b/Fine_Grained_Timing/test/FineGrainedTimingScopeTest.scala @@ -39,9 +39,20 @@ object FineGrainedTimingScopeTest { requireThat(proofs.isEmpty, "an incomplete named proof should not be partitioned") } + private def testQualifiedProofName(): Unit = { + requireThat( + FineGrainedTimingScope.proofName( + "lemma foo.first [simp]: \"True\"", + "lemma" + ) == "foo.first", + "qualified proof names should not be truncated" + ) + } + def main(_args: Array[String]): Unit = { testNamedProofPartitioning() testIncompleteNamedProofIsExcluded() + testQualifiedProofName() println("FineGrainedTimingScopeTest: all tests passed") } } diff --git a/Fine_Grained_Timing/test/FineGrainedTimingTest.scala b/Fine_Grained_Timing/test/FineGrainedTimingTest.scala index 17bae759..d5f56c76 100644 --- a/Fine_Grained_Timing/test/FineGrainedTimingTest.scala +++ b/Fine_Grained_Timing/test/FineGrainedTimingTest.scala @@ -130,6 +130,16 @@ object FineGrainedTimingTest { requireThat(merged.averageElapsedMicros == 3.75, "average elapsed time is incorrect") requireThat(merged.percentileElapsedMicros(0.5) == 3L, "p50 bucket is incorrect") requireThat(merged.percentileElapsedMicros(0.99) == 15L, "p99 bucket is incorrect") + val empty = + FineGrainedTiming.Aggregate( + 0L, + FineGrainedTiming.Timing(0L, 0L, 0L), + 0L, + 0L, + Map.empty + ) + requireThat(empty + merged == merged && merged + empty == merged, + "empty aggregate should be an additive identity") } def main(_args: Array[String]): Unit = { diff --git a/Fine_Grained_Timing/test/FineGrainedTimingTreeTableTest.scala b/Fine_Grained_Timing/test/FineGrainedTimingTreeTableTest.scala new file mode 100644 index 00000000..7843690e --- /dev/null +++ b/Fine_Grained_Timing/test/FineGrainedTimingTreeTableTest.scala @@ -0,0 +1,119 @@ +/* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT */ + +import java.awt.event.KeyEvent +import javax.swing.SwingUtilities + +object FineGrainedTimingTreeTableTest { + private final case class Row(name: String, total: String) + + private def requireThat(condition: Boolean, message: String): Unit = { + if (!condition) throw new RuntimeException(message) + } + + private def testExpansionAndReplacement(): Unit = { + val columns = + new FineGrainedTimingTreeTable.Columns { + override def count: Int = 2 + override def name(column: Int): String = + if (column == 0) "Name" else "Total" + override def columnClass(column: Int): Class[?] = + if (column == 0) + classOf[FineGrainedTimingTreeTable.TreeColumn] + else classOf[String] + override def valueAt(value: AnyRef, column: Int): AnyRef = + value match { + case Row(name, total) => if (column == 0) name else total + case FineGrainedTimingTreeTable.Loading => + if (column == 0) "Loading..." else "" + case _ => "" + } + } + val model = new FineGrainedTimingTreeTable.Model(columns) + val table = new FineGrainedTimingTreeTable.Table(model, treeColumn = 0) + + model.update(Vector( + FineGrainedTimingTreeTable.Data( + Row("signal", "2.0s"), + unloaded = true + ) + )) + table.refreshRows() + + val groupPath = + model.paths.collectFirst { + case (Row("signal", _), path) => path + }.getOrElse(sys.error("missing signal path")) + requireThat(table.getRowCount == 1, + s"collapsed group should occupy one row: ${table.getRowCount}") + requireThat(!table.tree.isExpanded(groupPath), + "new group should start collapsed") + requireThat(table.getModel.isCellEditable(0, 0), + "tree column must accept mouse events through its editor") + + table.setRowSelectionInterval(0, 0) + val expand = + new KeyEvent( + table, + KeyEvent.KEY_PRESSED, + System.currentTimeMillis(), + 0, + KeyEvent.VK_RIGHT, + KeyEvent.CHAR_UNDEFINED + ) + table.getKeyListeners.foreach(_.keyPressed(expand)) + requireThat(table.getRowCount == 2, + s"loading child should become visible: ${table.getRowCount}") + requireThat( + table.valueAtRow(1).contains(FineGrainedTimingTreeTable.Loading), + s"expanded unloaded group should show Loading: ${table.valueAtRow(1)}" + ) + + model.update(Vector( + FineGrainedTimingTreeTable.Data( + Row("signal", "2.0s"), + children = Vector( + FineGrainedTimingTreeTable.Data(Row("Theory", "2.0s")) + ) + ) + )) + val loadedGroupPath = + model.paths.collectFirst { + case (Row("signal", _), path) => path + }.getOrElse(sys.error("missing loaded signal path")) + table.tree.expandPath(loadedGroupPath) + table.refreshRows() + + requireThat(table.getRowCount == 2, + s"loaded child should replace placeholder: ${table.getRowCount}") + requireThat(table.valueAtRow(1).contains(Row("Theory", "2.0s")), + s"unexpected loaded child: ${table.valueAtRow(1)}") + requireThat(table.getValueAt(1, 1) == "2.0s", + s"timing column lost row alignment: ${table.getValueAt(1, 1)}") + + table.setRowSelectionInterval(0, 0) + val collapse = + new KeyEvent( + table, + KeyEvent.KEY_PRESSED, + System.currentTimeMillis(), + 0, + KeyEvent.VK_LEFT, + KeyEvent.CHAR_UNDEFINED + ) + table.getKeyListeners.foreach(_.keyPressed(collapse)) + requireThat(table.getRowCount == 1, + s"collapse should hide the child: ${table.getRowCount}") + } + + def main(_args: Array[String]): Unit = { + var failure = Option.empty[Throwable] + SwingUtilities.invokeAndWait(new Runnable { + override def run(): Unit = + try testExpansionAndReplacement() + catch { case exn: Throwable => failure = Some(exn) } + }) + failure.foreach(throw _) + println("FineGrainedTimingTreeTableTest: all tests passed") + } +} From 76db6586a84001e87ca629963286a1114a87b40d Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:29 +0100 Subject: [PATCH 16/46] AutoCorrode: Separate timing session from panel component Fine_Grained_Timing combined the proof session with the registered jEdit component. Registering the component to load its system options therefore exposed the session globally. Snapshot worktrees then found the same session again through `-d .` and failed with a duplicate session error. Keep the proof sources and session roots in `Fine_Grained_Timing`. Move the options, panel sources, resources, and build logic to the sessionless `Fine_Grained_Timing_Panel` component. Register only that component and keep `Fine_Grained_Timing` in `AutoCorrode/ROOTS`. Keep the session, theory, option, JAR, and markup names unchanged. Point the panel session test at the new source directory. Signed-off-by: Hanno Becker --- .../.gitignore | 0 .../Makefile | 6 ++++-- .../etc/options | 0 .../etc/settings | 0 .../resources/dockables.xml | 0 .../resources/plugin.props | 0 .../src/FineGrainedTiming.scala | 0 .../src/FineGrainedTimingDockable.scala | 0 .../src/FineGrainedTimingHierarchy.scala | 0 .../src/FineGrainedTimingPlugin.scala | 0 .../src/FineGrainedTimingScope.scala | 0 .../src/FineGrainedTimingTreeTable.scala | 0 .../test/FineGrainedTimingHierarchyTest.scala | 0 .../test/FineGrainedTimingScopeTest.scala | 0 .../test/FineGrainedTimingTest.scala | 0 .../test/FineGrainedTimingTreeTableTest.scala | 0 Makefile | 11 +++++++---- 17 files changed, 11 insertions(+), 6 deletions(-) rename {Fine_Grained_Timing => Fine_Grained_Timing_Panel}/.gitignore (100%) rename {Fine_Grained_Timing => Fine_Grained_Timing_Panel}/Makefile (95%) rename {Fine_Grained_Timing => Fine_Grained_Timing_Panel}/etc/options (100%) rename {Fine_Grained_Timing => Fine_Grained_Timing_Panel}/etc/settings (100%) rename {Fine_Grained_Timing => Fine_Grained_Timing_Panel}/resources/dockables.xml (100%) rename {Fine_Grained_Timing => Fine_Grained_Timing_Panel}/resources/plugin.props (100%) rename {Fine_Grained_Timing => Fine_Grained_Timing_Panel}/src/FineGrainedTiming.scala (100%) rename {Fine_Grained_Timing => Fine_Grained_Timing_Panel}/src/FineGrainedTimingDockable.scala (100%) rename {Fine_Grained_Timing => Fine_Grained_Timing_Panel}/src/FineGrainedTimingHierarchy.scala (100%) rename {Fine_Grained_Timing => Fine_Grained_Timing_Panel}/src/FineGrainedTimingPlugin.scala (100%) rename {Fine_Grained_Timing => Fine_Grained_Timing_Panel}/src/FineGrainedTimingScope.scala (100%) rename {Fine_Grained_Timing => Fine_Grained_Timing_Panel}/src/FineGrainedTimingTreeTable.scala (100%) rename {Fine_Grained_Timing => Fine_Grained_Timing_Panel}/test/FineGrainedTimingHierarchyTest.scala (100%) rename {Fine_Grained_Timing => Fine_Grained_Timing_Panel}/test/FineGrainedTimingScopeTest.scala (100%) rename {Fine_Grained_Timing => Fine_Grained_Timing_Panel}/test/FineGrainedTimingTest.scala (100%) rename {Fine_Grained_Timing => Fine_Grained_Timing_Panel}/test/FineGrainedTimingTreeTableTest.scala (100%) diff --git a/Fine_Grained_Timing/.gitignore b/Fine_Grained_Timing_Panel/.gitignore similarity index 100% rename from Fine_Grained_Timing/.gitignore rename to Fine_Grained_Timing_Panel/.gitignore diff --git a/Fine_Grained_Timing/Makefile b/Fine_Grained_Timing_Panel/Makefile similarity index 95% rename from Fine_Grained_Timing/Makefile rename to Fine_Grained_Timing_Panel/Makefile index db9bc9e5..c7a6e10d 100644 --- a/Fine_Grained_Timing/Makefile +++ b/Fine_Grained_Timing_Panel/Makefile @@ -1,10 +1,11 @@ -# Makefile for the Fine-Grained Timing component and jEdit plugin +# Makefile for the Fine-Grained Timing panel component ifndef V .SILENT: endif COMPONENT_DIR := $(shell pwd) +FINE_GRAINED_TIMING_DIR ?= $(COMPONENT_DIR)/../Fine_Grained_Timing ISABELLE_HOME ?= /Applications/Isabelle2025-2.app ifneq ($(wildcard $(ISABELLE_HOME)/bin/isabelle),) ISABELLE_INSTALLATION_HOME := $(abspath $(ISABELLE_HOME)) @@ -64,7 +65,8 @@ test: build $(TEST_CLASSES_DIR)/.compiled echo "Fine-Grained Timing Scala tests passed." session-test: - $(ISABELLE) build -d . Fine_Grained_Timing_Test + $(ISABELLE) build -d "$(FINE_GRAINED_TIMING_DIR)" \ + Fine_Grained_Timing_Test register: $(ISABELLE) components -u "$(COMPONENT_DIR)" diff --git a/Fine_Grained_Timing/etc/options b/Fine_Grained_Timing_Panel/etc/options similarity index 100% rename from Fine_Grained_Timing/etc/options rename to Fine_Grained_Timing_Panel/etc/options diff --git a/Fine_Grained_Timing/etc/settings b/Fine_Grained_Timing_Panel/etc/settings similarity index 100% rename from Fine_Grained_Timing/etc/settings rename to Fine_Grained_Timing_Panel/etc/settings diff --git a/Fine_Grained_Timing/resources/dockables.xml b/Fine_Grained_Timing_Panel/resources/dockables.xml similarity index 100% rename from Fine_Grained_Timing/resources/dockables.xml rename to Fine_Grained_Timing_Panel/resources/dockables.xml diff --git a/Fine_Grained_Timing/resources/plugin.props b/Fine_Grained_Timing_Panel/resources/plugin.props similarity index 100% rename from Fine_Grained_Timing/resources/plugin.props rename to Fine_Grained_Timing_Panel/resources/plugin.props diff --git a/Fine_Grained_Timing/src/FineGrainedTiming.scala b/Fine_Grained_Timing_Panel/src/FineGrainedTiming.scala similarity index 100% rename from Fine_Grained_Timing/src/FineGrainedTiming.scala rename to Fine_Grained_Timing_Panel/src/FineGrainedTiming.scala diff --git a/Fine_Grained_Timing/src/FineGrainedTimingDockable.scala b/Fine_Grained_Timing_Panel/src/FineGrainedTimingDockable.scala similarity index 100% rename from Fine_Grained_Timing/src/FineGrainedTimingDockable.scala rename to Fine_Grained_Timing_Panel/src/FineGrainedTimingDockable.scala diff --git a/Fine_Grained_Timing/src/FineGrainedTimingHierarchy.scala b/Fine_Grained_Timing_Panel/src/FineGrainedTimingHierarchy.scala similarity index 100% rename from Fine_Grained_Timing/src/FineGrainedTimingHierarchy.scala rename to Fine_Grained_Timing_Panel/src/FineGrainedTimingHierarchy.scala diff --git a/Fine_Grained_Timing/src/FineGrainedTimingPlugin.scala b/Fine_Grained_Timing_Panel/src/FineGrainedTimingPlugin.scala similarity index 100% rename from Fine_Grained_Timing/src/FineGrainedTimingPlugin.scala rename to Fine_Grained_Timing_Panel/src/FineGrainedTimingPlugin.scala diff --git a/Fine_Grained_Timing/src/FineGrainedTimingScope.scala b/Fine_Grained_Timing_Panel/src/FineGrainedTimingScope.scala similarity index 100% rename from Fine_Grained_Timing/src/FineGrainedTimingScope.scala rename to Fine_Grained_Timing_Panel/src/FineGrainedTimingScope.scala diff --git a/Fine_Grained_Timing/src/FineGrainedTimingTreeTable.scala b/Fine_Grained_Timing_Panel/src/FineGrainedTimingTreeTable.scala similarity index 100% rename from Fine_Grained_Timing/src/FineGrainedTimingTreeTable.scala rename to Fine_Grained_Timing_Panel/src/FineGrainedTimingTreeTable.scala diff --git a/Fine_Grained_Timing/test/FineGrainedTimingHierarchyTest.scala b/Fine_Grained_Timing_Panel/test/FineGrainedTimingHierarchyTest.scala similarity index 100% rename from Fine_Grained_Timing/test/FineGrainedTimingHierarchyTest.scala rename to Fine_Grained_Timing_Panel/test/FineGrainedTimingHierarchyTest.scala diff --git a/Fine_Grained_Timing/test/FineGrainedTimingScopeTest.scala b/Fine_Grained_Timing_Panel/test/FineGrainedTimingScopeTest.scala similarity index 100% rename from Fine_Grained_Timing/test/FineGrainedTimingScopeTest.scala rename to Fine_Grained_Timing_Panel/test/FineGrainedTimingScopeTest.scala diff --git a/Fine_Grained_Timing/test/FineGrainedTimingTest.scala b/Fine_Grained_Timing_Panel/test/FineGrainedTimingTest.scala similarity index 100% rename from Fine_Grained_Timing/test/FineGrainedTimingTest.scala rename to Fine_Grained_Timing_Panel/test/FineGrainedTimingTest.scala diff --git a/Fine_Grained_Timing/test/FineGrainedTimingTreeTableTest.scala b/Fine_Grained_Timing_Panel/test/FineGrainedTimingTreeTableTest.scala similarity index 100% rename from Fine_Grained_Timing/test/FineGrainedTimingTreeTableTest.scala rename to Fine_Grained_Timing_Panel/test/FineGrainedTimingTreeTableTest.scala diff --git a/Makefile b/Makefile index 32bf0f54..62e3fb6c 100644 --- a/Makefile +++ b/Makefile @@ -8,7 +8,8 @@ ###################################################################### .DEFAULT_GOAL: jedit -.PHONY: register-components register-afp-components register-timing-component \ +.PHONY: register-components register-afp-components \ + register-fine-grained-timing-panel-component \ build autolocality-tests autolocality-stress jedit tutorial \ build-ic2 ic2 ic2-status ic2-stop @@ -44,13 +45,15 @@ ISABELLE_JEDIT_FLAGS += $(ISABELLE_REMOTE) jedit: register-components $(ISABELLE_HOME)/isabelle jedit $(ISABELLE_JEDIT_FLAGS) -l HOL -d . ./AutoCorrode.thy & -register-components: register-afp-components register-timing-component +register-components: register-afp-components \ + register-fine-grained-timing-panel-component register-afp-components: $(ISABELLE_HOME)/isabelle components -u $(AFP_COMPONENT_BASE)/Word_Lib -register-timing-component: - $(ISABELLE_HOME)/isabelle components -u $(CURDIR)/Fine_Grained_Timing +register-fine-grained-timing-panel-component: + $(MAKE) -C Fine_Grained_Timing_Panel \ + ISABELLE_HOME=$(ISABELLE_HOME) register build: register-components $(ISABELLE_HOME)/isabelle build $(ISABELLE_FLAGS) -d . \ From d88b0544160ac3feedca779a5190a7232269be0d Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:29 +0100 Subject: [PATCH 17/46] Crush: Try crule branches before premise unfolding Crush tries the branches of its step tactic in list order. `aentails_cond_crule_tac` and `aentails_crule_tac` sat after `unfold_prems_tac`, `aentails_core_tac`, and `aentails_drule_tac`, so a goal that a registered `crule` closes directly was first put through premise unfolding and the core and drule branches. Move both crule branches directly after `aentails_cancel_tac`. A goal with a matching `crule` now takes it first; the relative order of the remaining branches is unchanged. This changes which proof `crush` finds for goals reachable both ways, so proofs that relied on the earlier branch order may need adjusting. Signed-off-by: Hanno Becker --- Crush/crush.ML | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Crush/crush.ML b/Crush/crush.ML index c43412d8..4c69c48f 100644 --- a/Crush/crush.ML +++ b/Crush/crush.ML @@ -568,11 +568,11 @@ struct ("urust_determine_branch" , \<^here>, (fn _ => crush_branch_determine_branch ctxt)), ("call_tac (no schematics)", \<^here>, (fn _ => crush_branch_call_tac ctxt false unfold_contract_tac)), ("aentails_cancel_tac" , \<^here>, (fn _ => crush_branch_aentails_cancel_tac ctxt)), + ("aentails_cond_crule_tac" , \<^here>, (fn _ => crush_branch_aentails_cond_crule_tac ctxt)), + ("aentails_crule_tac" , \<^here>, (fn _ => crush_branch_aentails_crule_tac ctxt)), ("unfold_prems_tac" , \<^here>, (fn _ => crush_branch_unfold_prems_tac ctxt)), ("aentails_core_tac" , \<^here>, (fn _ => crush_branch_aentails_core_tac ctxt)), ("aentails_drule_tac" , \<^here>, (fn _ => crush_branch_aentails_drule_tac ctxt)), - ("aentails_cond_crule_tac" , \<^here>, (fn _ => crush_branch_aentails_cond_crule_tac ctxt)), - ("aentails_crule_tac" , \<^here>, (fn _ => crush_branch_aentails_crule_tac ctxt)), ("aentails_rule_tac" , \<^here>, (fn _ => crush_branch_aentails_rule_tac ctxt)), ("unfold_concls_tac" , \<^here>, (fn _ => crush_branch_unfold_concls_tac ctxt)), ("schematics_tac" , \<^here>, (fn _ => crush_branch_schematics_tac ctxt unfold_contract_tac)), From cdb8459600d78eed98ff81b44135956afb8719d1 Mon Sep 17 00:00:00 2001 From: Lawrence Paulson Date: Thu, 24 Sep 2026 17:48:29 +0100 Subject: [PATCH 18/46] AutoLocality: Don't unfold baked-in logical-core constants state_locality_for_op collected every Const-headed argument of a partial application into baked_cnames, and default_simps then unfolded each one's definition when discharging. For locality_lemma for perf: footprint [qc] the baked argument is True, so HOL.True_def reached the simplifier. True is simp's own normal form, so rewriting it via True == ((%x::bool. x) = (%x. x)) destroys the normalisation that discharges side conditions and collapses the output of if_split. The automatic discharge then diverged instead of failing, and the command died with Interrupt_Breakdown after Poly/ML could no longer grow the stack -- with nothing in the trace, because that code path carries a counter but no trace point. A baked constant is now unfolded only if (1) its type mentions the record type -- a bool, numeral or string literal carries no record structure, so unfolding it can reveal no field; and (2) it is not declared by the logical core, i.e. by a theory at or below HOL. Both guards are needed: only (1) excludes numerals, and only (2) excludes undefined :: rec => _. The declaring theory is resolved through the constant name space (Name_Space.theory_name, Theory.check, Context.subthy) rather than by inspecting the long name, so a user constant that merely sits in a HOL-prefixed namespace is not misclassified. Narrowing this list cannot rename any generated fact: locality_public_id decides partial-application naming from p_term with its own, deliberately broader, test. AutoLocality_Test_Perf.thy now discharges, and AutoLocality_Test_Shapes_Wide.thy still passes -- its w_apply_policy policy_a footprints only close if policy_a_def is still unfolded, so the narrowing does not overshoot. Signed-off-by: Lawrence Paulson --- Autogen/AutoLocality.thy | 42 +++++++++++++++++++++++++++++++++++++++- 1 file changed, 41 insertions(+), 1 deletion(-) diff --git a/Autogen/AutoLocality.thy b/Autogen/AutoLocality.thy index 48f30def..b9dda409 100644 --- a/Autogen/AutoLocality.thy +++ b/Autogen/AutoLocality.thy @@ -4801,8 +4801,48 @@ ML\ the Const-headed arguments count: they are what the baked-in operator must carry. Locale parameters are left to the ordinary 'make_arglist'/'num_args' machinery (which fills the remaining argument positions), so the locale case keeps the original behaviour. *) + (* Baked-in constants enter 'discharge_cnames' below, so their definitions are unfolded by + the automatic discharge in order to expose the field footprint: 'w_apply_policy policy_a' + needs 'policy_a_def' before wf04 becomes visible. Two guards keep that from unfolding + arguments where it cannot help. + + (1) The constant's type must mention the record type. A bool, numeral or string literal + carries no record structure, so unfolding it can reveal no field of the record. + + (2) The constant must not be declared by the logical core, i.e. by a theory at or below + \<^theory>\HOL\. Core constants do have definitions, but those are the + axiomatic underpinning of the logic rather than operations on data: + \<^const>\True\ is defined as \<^term>\(\x::bool. x) = (\x. x)\, + so handing 'True_def' to the simplifier rewrites its own normal form and the + discharge diverges instead of failing. + + The declaring theory is resolved through the constant name space rather than by + inspecting the long name, so a user constant that merely happens to sit in a + 'HOL'-prefixed namespace is not misclassified. Narrowing this list cannot rename any + generated fact: 'locality_public_id' decides partial-application naming from 'p_term' + with its own, deliberately broader, test. *) + fun baked_const_unfoldable (c, T) = + let + val mentions_record = + T |> Term.exists_subtype (fn Type (n, _) => n = rec_name | _ => false) + val declaring_theory = + try (Name_Space.theory_name {long = true} + (Consts.space_of (Proof_Context.consts_of ctxt))) c + val from_logical_core = + (case declaring_theory of + NONE => false + | SOME thy_name => + (case try (Theory.check {long = true} ctxt) (thy_name, Position.none) of + NONE => false + | SOME thy => Context.subthy (thy, \<^theory>\HOL\))) + in + mentions_record andalso not from_logical_core + end + val baked_cnames = snd (Term.strip_comb p_term) |> map_filter (fn t => - case Term.head_of t of Const (c, _) => SOME c | _ => NONE) + case Term.head_of t of + Const (c, T) => if baked_const_unfoldable (c, T) then SOME c else NONE + | _ => NONE) (* Identifier used for the generated fact names. For a bare constant (or one applied only to locale parameters) this is its base name, keeping the common-case names stable; for a genuine From d34f47906a350bb4ae9fb9bc12aa3fd46532d790 Mon Sep 17 00:00:00 2001 From: Lawrence Paulson Date: Thu, 24 Sep 2026 17:48:30 +0100 Subject: [PATCH 19/46] Balance meta-comment (*<*)/(*>*) markers Isabelle2026 checks that document-preparation meta-comments nest properly across a theory (Document_Output.check_nesting, called from present_thy): Meta-comments (*<*)...(*>*) need to be properly nested: this was never checked in the past. INCOMPATIBILITY. Both an unmatched (*>*) and an unclosed (*<*) are now errors, reported as "Bad nesting of meta-comments". Six files were unbalanced, in two shapes: - missing opener before the final `end`: StdLib_Result, StdLib_Option, StdLib_Contracts, References, Weak_Triple - opener left unclosed at end of file: Basic_Micro_Rust These are cosmetic defects in the boilerplate-hiding markup that never affected any proof, which is why they accumulated unnoticed: only document preparation reads the markers, and most sessions run with document=false. The change is balance-only, so it is equally valid under Isabelle2025-2; it is separated from the Isabelle2026 migration proper so it can be taken on its own. Signed-off-by: Lawrence Paulson --- Micro_Rust_Examples/Basic_Micro_Rust.thy | 1 + Micro_Rust_Interfaces_Core/References.thy | 1 + Micro_Rust_Std_Lib/StdLib_Contracts.thy | 1 + Micro_Rust_Std_Lib/StdLib_Option.thy | 1 + Micro_Rust_Std_Lib/StdLib_Result.thy | 1 + Shallow_Separation_Logic/Weak_Triple.thy | 1 + 6 files changed, 6 insertions(+) diff --git a/Micro_Rust_Examples/Basic_Micro_Rust.thy b/Micro_Rust_Examples/Basic_Micro_Rust.thy index 17a034bd..b6bcd7ac 100644 --- a/Micro_Rust_Examples/Basic_Micro_Rust.thy +++ b/Micro_Rust_Examples/Basic_Micro_Rust.thy @@ -400,6 +400,7 @@ definition add_local :: \('s, 64 word, _, _, _, _) expression\ wher (*<*) end +(*>*) text\You may have noted that we didn't run any experimental evaluations. To be able to conduct such, we would first need to exhibit a concrete \<^emph>\implementation\ of the interfaces exposed diff --git a/Micro_Rust_Interfaces_Core/References.thy b/Micro_Rust_Interfaces_Core/References.thy index 193fa81a..eeba1309 100644 --- a/Micro_Rust_Interfaces_Core/References.thy +++ b/Micro_Rust_Interfaces_Core/References.thy @@ -249,6 +249,7 @@ lemma aentails_cancel_points_to_raw_with_typed_0R: using aentails_cancel_points_to_raw_with_typed by (metis asepconj_ident2 assms ucincl_points_to_raw) declare reference_axioms [reference_axioms] +(*<*) end end diff --git a/Micro_Rust_Std_Lib/StdLib_Contracts.thy b/Micro_Rust_Std_Lib/StdLib_Contracts.thy index 5132f27b..9ec0984a 100644 --- a/Micro_Rust_Std_Lib/StdLib_Contracts.thy +++ b/Micro_Rust_Std_Lib/StdLib_Contracts.thy @@ -169,5 +169,6 @@ using assms satisfies_function_contract_weaken) done +(*<*) end (*>*) \ No newline at end of file diff --git a/Micro_Rust_Std_Lib/StdLib_Option.thy b/Micro_Rust_Std_Lib/StdLib_Option.thy index e678edd2..65892faa 100644 --- a/Micro_Rust_Std_Lib/StdLib_Option.thy +++ b/Micro_Rust_Std_Lib/StdLib_Option.thy @@ -188,5 +188,6 @@ instance .. end +(*<*) end (*>*) \ No newline at end of file diff --git a/Micro_Rust_Std_Lib/StdLib_Result.thy b/Micro_Rust_Std_Lib/StdLib_Result.thy index e0fa058a..4cfbe064 100644 --- a/Micro_Rust_Std_Lib/StdLib_Result.thy +++ b/Micro_Rust_Std_Lib/StdLib_Result.thy @@ -212,5 +212,6 @@ instance .. end +(*<*) end (*>*) \ No newline at end of file diff --git a/Shallow_Separation_Logic/Weak_Triple.thy b/Shallow_Separation_Logic/Weak_Triple.thy index e231a0f1..5e76dda0 100644 --- a/Shallow_Separation_Logic/Weak_Triple.thy +++ b/Shallow_Separation_Logic/Weak_Triple.thy @@ -1254,6 +1254,7 @@ proof - qed +(*<*) end end From c88b679e1bd2af045ca61bc466b0f1ab6216ac39 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:30 +0100 Subject: [PATCH 20/46] Fine-Grained Timing: Apply the threshold to every sink Fine-grained timing can publish each sample through multiple built-in outputs. `timing_threshold_us` is meant to discard short samples before they reach those outputs, but the threshold was checked only for PIDE reports. Enabling `fine_grained_timing_output` therefore printed samples that PIDE omitted. Check `timing_threshold_us` in the tracing sink as well. Keep sinks added through `add_sink` unchanged: they receive raw samples and remain responsible for filtering them. Signed-off-by: Hanno Becker --- Fine_Grained_Timing/time.ML | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/Fine_Grained_Timing/time.ML b/Fine_Grained_Timing/time.ML index 45957017..ccaf807f 100644 --- a/Fine_Grained_Timing/time.ML +++ b/Fine_Grained_Timing/time.ML @@ -389,7 +389,11 @@ struct ("fine_grained_timing", properties) (YXML.string_of_body body) end - fun above_pide_threshold ctxt ({timing, ...}: timing_result) = + (* `timing_threshold_us` gates every sink, not just PIDE: it is the + user-facing statement that samples below it are noise. Filtering in the + PIDE sink alone makes `fine_grained_timing_output` trace every + sub-microsecond sample. *) + fun above_threshold ctxt ({timing, ...}: timing_result) = let val threshold = Time.fromMicroseconds (Config.get ctxt timing_threshold_us) in #elapsed timing > threshold end @@ -400,17 +404,19 @@ struct [] => NONE | statistics :: _ => SOME (fn result as {name, success, timing} => - if above_pide_threshold ctxt result then + if above_threshold ctxt result then Fine_Grained_Timing_Accumulator.add statistics (name, success, timing) else ())) fun output_sink_factory ctxt = if Config.get ctxt output_enabled then - SOME (fn {name, success, timing} => - tracing ("fine-grained timing " ^ quote name ^ " " ^ - (if success then "success" else "failure") ^ ": " ^ - Timing.message timing)) + SOME (fn result as {name, success, timing} => + if above_threshold ctxt result then + tracing ("fine-grained timing " ^ quote name ^ " " ^ + (if success then "success" else "failure") ^ ": " ^ + Timing.message timing) + else ()) else NONE structure Sink_Data = Proof_Data ( From 77bfc60c095c3540904f21ca874a5645e7bc0aaf Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:30 +0100 Subject: [PATCH 21/46] Fine-Grained Timing: Report failed methods as failed Fine-grained timing records whether an Isabelle tactic or method invocation succeeds. A method can return an error as its first result, but the profiler treated any first result as success. For example, an invalid `goal_cases` argument was reported with `success="true"` even though the method had failed. Make the generic result profiler accept a predicate that identifies successful results. Tactic results always count as successful, while method results count as successful only when they are `Seq.Result`; `Seq.Error` remains a failure. Signed-off-by: Hanno Becker --- .../test/Fine_Grained_Timing_Test.thy | 15 ++++++++++++- Fine_Grained_Timing/time.ML | 22 +++++++++++++------ 2 files changed, 29 insertions(+), 8 deletions(-) diff --git a/Fine_Grained_Timing/test/Fine_Grained_Timing_Test.thy b/Fine_Grained_Timing/test/Fine_Grained_Timing_Test.thy index b967ceb5..4566e724 100644 --- a/Fine_Grained_Timing/test/Fine_Grained_Timing_Test.thy +++ b/Fine_Grained_Timing/test/Fine_Grained_Timing_Test.thy @@ -98,7 +98,7 @@ ML \ val profile_context = Config.put Fine_Grained_Timing.enabled true @{context} val profile_result = - Fine_Grained_Timing.profile_seq "generic_profile" profile_context + Fine_Grained_Timing.profile_seq (K true) "generic_profile" profile_context (fn ctxt => Seq.single (Fine_Grained_Timing.active ctxt)) |> Seq.pull @@ -110,6 +110,19 @@ ML \ if Fine_Grained_Timing.active profile_context then error "Generic profile changed its input context" else () + + (* `profile_method` must tell a method that failed from one that yielded no + result at all, so the outcome predicate has to see `Seq.Error`. *) + val error_result = + Fine_Grained_Timing.profile_seq + (fn Seq.Result _ => true | Seq.Error _ => false) + "error_profile" profile_context + (fn _ => Seq.single (Seq.Error (fn () => "failed"))) + |> Seq.pull + val _ = + (case error_result of + SOME (Seq.Error _, _) => () + | _ => error "Profiling dropped or rewrote a Seq.Error result") \ method_setup assert_no_fine_grained_profile = diff --git a/Fine_Grained_Timing/time.ML b/Fine_Grained_Timing/time.ML index ccaf807f..2bf4b1a3 100644 --- a/Fine_Grained_Timing/time.ML +++ b/Fine_Grained_Timing/time.ML @@ -116,9 +116,11 @@ sig -> (unit -> (Timing.timing * bool) * 'a) (* Create one PIDE aggregation boundary around an arbitrary lazy sequence. - The string is the invocation label shown in the report header. *) - val profile_seq : - string -> Proof.context -> (Proof.context -> 'a Seq.seq) -> 'a Seq.seq + The string is the invocation label shown in the report header. The + predicate decides whether a pulled element counts as a successful + outcome; element types that cannot carry failure use `K true`. *) + val profile_seq : ('a -> bool) + -> string -> Proof.context -> (Proof.context -> 'a Seq.seq) -> 'a Seq.seq val profile_tactic : string -> Proof.context -> (Proof.context -> tactic) -> tactic @@ -545,7 +547,7 @@ struct PIDE stack frame and performs a plain pull. Nested `time` operations resolve the statically registered PIDE sink against that frame. *) - fun profile_seq invocation_name ctxt make_sequence = + fun profile_seq element_success invocation_name ctxt make_sequence = if not (Config.get ctxt enabled) then make_sequence ctxt else @@ -566,12 +568,16 @@ struct Seq.make (fn _ => let val output = Seq.pull (make_sequence ctxt') - val _ = emit_pide_report ctxt' invocation (is_some output) + val success = + (case output of + NONE => false + | SOME (element, _) => element_success element) + val _ = emit_pide_report ctxt' invocation success in output end) end fun profile_tactic invocation_name ctxt make_tactic state = - profile_seq invocation_name ctxt + profile_seq (K true) invocation_name ctxt (fn ctxt' => make_tactic ctxt' state) (* Methods additionally return proof contexts. Restore the caller's profile @@ -581,7 +587,9 @@ struct val ctxt = fst context val profiles = PIDE_Profiles.get ctxt in - profile_seq invocation_name ctxt + profile_seq + (fn Seq.Result _ => true | Seq.Error _ => false) + invocation_name ctxt (fn ctxt' => make_method ctxt' facts (ctxt', snd context)) |> Seq.map_result (fn (result_ctxt, result) => (PIDE_Profiles.put profiles result_ctxt, result)) From 0545c9a44eb708708bfb36619adebe8f7f2d8cb0 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:30 +0100 Subject: [PATCH 22/46] Fine-Grained Timing: Collect complete timing reports Fine-grained timing reports the elapsed time and outcome of an Isabelle tactic or method invocation. An invocation can produce more than one result while the prover backtracks. The profiler published only the first result, so later work could add nested samples or change the final outcome without updating the report. Summing all samples is also wrong: an outer timed call already includes time spent in nested calls. Keep measuring every result at the profiling boundary and publish cumulative reports under one invocation ID. Include the elapsed time of the outer call. The Scala panel and Python inspector now collect every report for a command and keep the one with the most samples, then prefer a successful outcome and the greatest outer elapsed time. Mark discarded Python reports as `superseded`. Timing reports use a versioned format. Version 2 now includes the outer elapsed time, while readers continue to accept older version 2 reports that do not contain it. Signed-off-by: Hanno Becker --- .../test/Fine_Grained_Timing_Test.thy | 150 +++++++++++++++++- Fine_Grained_Timing/time.ML | 143 +++++++++++++---- .../src/FineGrainedTiming.scala | 81 +++++++++- .../src/FineGrainedTimingDockable.scala | 43 +++-- .../test/FineGrainedTimingTest.scala | 103 ++++++++++-- ip/fine_timing.py | 51 +++++- ip/heap-db-inspect | 39 ++++- ip/test_fine_timing.py | 88 ++++++++-- 8 files changed, 608 insertions(+), 90 deletions(-) diff --git a/Fine_Grained_Timing/test/Fine_Grained_Timing_Test.thy b/Fine_Grained_Timing/test/Fine_Grained_Timing_Test.thy index 4566e724..75ea411c 100644 --- a/Fine_Grained_Timing/test/Fine_Grained_Timing_Test.thy +++ b/Fine_Grained_Timing/test/Fine_Grained_Timing_Test.thy @@ -111,8 +111,154 @@ ML \ error "Generic profile changed its input context" else () - (* `profile_method` must tell a method that failed from one that yielded no - result at all, so the outcome predicate has to see `Seq.Error`. *) + (* A profile reports again on every pull that added samples, so the wrapper + around the tail must leave the sequence fully enumerable, and nested + samples must keep reaching the accumulator while the caller backtracks. *) + val backtrack_samples = + Synchronized.var "backtracking timing test sink" ([]: string list) + val backtrack_context = + profile_context + |> Fine_Grained_Timing.add_sink "test_backtrack" + (fn _ => + SOME (fn {name, ...}: Fine_Grained_Timing.timing_result => + Synchronized.change backtrack_samples (cons name))) + val backtrack_result = + Fine_Grained_Timing.profile_seq (K true) "backtracking" backtrack_context + (fn ctxt => + Seq.of_list [1, 2, 3] + |> Seq.map (fn n => + Fine_Grained_Timing.time_and_report ctxt "element" true + (fn () => n))) + |> Seq.list_of + + val _ = + if backtrack_result = [1, 2, 3] then () + else error "Profiling a sequence changed the elements it yields" + val _ = + let val collected = length (Synchronized.value backtrack_samples) + in + if collected = 3 then () + else error ("Backtracking past the first result lost nested samples: \ + \expected 3, got " ^ Value.print_int collected) + end + + (* Samples gathered while backtracking are worthless unless they are also + reported. Each pull that adds samples must emit a fresh snapshot, and + every snapshot of one invocation must carry the same id. *) + val observed_reports = + Synchronized.var "profile report observer" ([]: Properties.T list) + val observing_context = + profile_context + |> Config.put Fine_Grained_Timing.timing_threshold_us 0 + |> Fine_Grained_Timing.set_report_observer + (fn _ => fn properties => fn _ => + Synchronized.change observed_reports (cons properties)) + val _ = + Fine_Grained_Timing.profile_seq (K true) "observed" observing_context + (fn ctxt => + Seq.of_list [1, 2, 3] + |> Seq.map (fn n => + Fine_Grained_Timing.time_and_report ctxt "element" true + (fn () => + (* Sleep so the sample clears the reporting threshold; a pure + computation can measure as zero elapsed time. *) + (OS.Process.sleep (Time.fromMilliseconds 1); n)))) + |> Seq.list_of + + val _ = + let + val reported = Synchronized.value observed_reports + val invocations = + distinct (op =) + (map_filter (fn properties => + Properties.get properties "invocation") reported) + in + if length reported < 3 then + error ("A profile stopped reporting while the caller backtracked: \ + \expected at least 3 reports, got " ^ + Value.print_int (length reported)) + else if length invocations <> 1 then + error ("Reports of one invocation disagreed on its id: " ^ + commas_quote invocations) + else () + end + + (* An error result can be followed by a successful result without adding a + timing sample. The changed outcome still needs a new snapshot. *) + val outcome_reports = + Synchronized.var "profile outcome observer" ([]: Properties.T list) + val outcome_context = + profile_context + |> Fine_Grained_Timing.set_report_observer + (fn _ => fn properties => fn _ => + Synchronized.change outcome_reports (cons properties)) + val outcome_result = + Fine_Grained_Timing.profile_seq I "outcome" outcome_context + (fn _ => Seq.of_list [false, true]) + |> Seq.list_of + val _ = + if outcome_result = [false, true] then () + else error "Profiling changed an outcome test sequence" + val _ = + let + val reported = Synchronized.value outcome_reports + in + if length reported < 2 then + error "An outcome change did not emit a second profile snapshot" + else if + Properties.get (hd reported) "success" = SOME "true" andalso + is_some (Properties.get (hd reported) "elapsed_us") andalso + exists + (fn properties => + Properties.get properties "success" = SOME "false") + (tl reported) + then () + else error "Profile snapshots did not preserve the latest outcome" + end + + (* Pulls without nested samples still contribute to the invocation total. + They must publish a newer snapshot when the outcome is unchanged. *) + val timing_reports = + Synchronized.var "profile timing observer" ([]: Properties.T list) + val timing_context = + profile_context + |> Fine_Grained_Timing.set_report_observer + (fn _ => fn properties => fn _ => + Synchronized.change timing_reports (cons properties)) + fun delayed_sequence [] = + Seq.make (fn _ => + (OS.Process.sleep (Time.fromMilliseconds 2); NONE)) + | delayed_sequence (value :: values) = + Seq.make (fn _ => + (OS.Process.sleep (Time.fromMilliseconds 2); + SOME (value, delayed_sequence values))) + val timing_result = + Fine_Grained_Timing.profile_seq (K true) "timing_only" timing_context + (fn _ => delayed_sequence [1, 2]) + |> Seq.list_of + val _ = + if timing_result = [1, 2] then () + else error "Profiling changed a timing-only sequence" + val _ = + (case Synchronized.value timing_reports of + latest :: earlier :: _ => + let + val latest_elapsed = + the_default 0 + (Properties.get latest "elapsed_us" + |> Option.map Value.parse_int) + val earlier_elapsed = + the_default 0 + (Properties.get earlier "elapsed_us" + |> Option.map Value.parse_int) + in + if latest_elapsed > earlier_elapsed then () + else error "A timing-only pull did not publish a newer snapshot" + end + | _ => error "Timing-only pulls did not emit repeated snapshots") + + (* `profile_method` distinguishes a failing method from one that yields no + result at all, so the outcome predicate must see `Seq.Error`. *) val error_result = Fine_Grained_Timing.profile_seq (fn Seq.Result _ => true | Seq.Error _ => false) diff --git a/Fine_Grained_Timing/time.ML b/Fine_Grained_Timing/time.ML index 2bf4b1a3..34255655 100644 --- a/Fine_Grained_Timing/time.ML +++ b/Fine_Grained_Timing/time.ML @@ -9,7 +9,7 @@ This file has three jobs: 1. measure named operations only when at least one sink wants the sample; 2. deliver each sample to all active sinks; and - 3. let `profile` bundle PIDE samples into one report. + 3. let `profile` bundle PIDE samples into invocation snapshots. Sink factories are stored in the proof context. A factory receives the current context and returns either an active callback or `NONE`. The two default @@ -42,19 +42,18 @@ The factory, rather than the callback, receives the proof context. This lets a sink inspect configuration once for each `time` wrapper. If the factory returns `NONE`, that destination adds no measurement overhead beyond sink resolution. -`profile` does not measure its wrapped operation. It pushes a fresh synchronized -PIDE accumulator, performs one ordinary sequence pull, and emits one report -containing the samples produced by nested `time` wrappers. To include a total, -write it explicitly: - - apply (profile ‹time "total" ‹my_method››) +`profile` pushes a fresh synchronized PIDE accumulator and measures each pull +of its wrapped sequence. The report header carries the accumulated invocation +time, while the body contains samples produced by nested `time` wrappers. +Lazy methods may emit updated snapshots when later pulls add samples or change +the invocation outcome. Nested profiles push another accumulator. The PIDE sink writes only to the top stack frame, so the inner samples are not counted again by the outer profile. After the inner profile returns, later samples go to the outer frame. -One report per profile is deliberate. A method may produce millions of -samples; aggregation keeps PIDE traffic bounded. +Reports are complete snapshots, not increments. Consumers keep the newest +snapshot of each invocation instead of adding snapshots together. *) signature FINE_GRAINED_TIMING = @@ -110,6 +109,11 @@ sig val timing_threshold_us : int Config.T val active : Proof.context -> bool + (* Divert invocation reports away from PIDE markup, for tests. *) + val set_report_observer : + (Position.T -> Properties.T -> string -> unit) + -> Proof.context -> Proof.context + val time_it : (unit -> 'a) -> (unit -> Timing.timing * 'a) val time_and_report : Proof.context -> string -> bool -> (unit -> 'a) -> 'a val time_it_with_status : (unit -> 'a) -> ('a -> bool) @@ -343,7 +347,8 @@ struct id: int, invocation_name: string, position: Position.T, - statistics: Fine_Grained_Timing_Accumulator.T + statistics: Fine_Grained_Timing_Accumulator.T, + timing: Timing.timing Synchronized.var } (* The stack itself is immutable context data. Each entry is a fresh @@ -355,6 +360,16 @@ struct fun active ctxt = not (null (PIDE_Profiles.get ctxt)) + (* Report emission is context-local so that tests can observe it directly. + `Context_Position.report_text` is silent whenever the context is + invisible, as it is in a batch build, which would otherwise leave the + report schedule untestable. *) + structure Report_Observer = Proof_Data ( + type T = (Position.T -> Properties.T -> string -> unit) option + val init = K NONE) + + fun set_report_observer observe = Report_Observer.put (SOME observe) + (* PIDE report schema version 2: @@ -366,34 +381,46 @@ struct ...encoded aggregate entries... - The header deliberately has no implicit outer timing. `profile` controls - the accumulator lifetime but does not generate a measurement. Users who - need a total add an explicit outer `time` wrapper. + The header carries the cumulative time spent pulling results from the + profiled sequence. The aggregate entries describe named work recorded by + nested `time` wrappers and may overlap with each other and with the outer + timing. The aggregate entries are passed as YXML text because report markup has a text payload. The Scala decoder accepts this representation and the nested XML form used by tests. Position-attached markup follows PIDE document lifetime, so edited commands do not leave stale reports. *) + fun encode_time time = Value.print_int (Time.toMicroseconds time) + fun emit_pide_report ctxt - ({id, invocation_name, position, statistics}: pide_invocation) success = + ({id, invocation_name, position, statistics, timing}: pide_invocation) + success = let + val total = Synchronized.value timing val properties = [ ("version", "2"), ("invocation", Value.print_int id), ("method", invocation_name), - ("success", Bool.toString success) + ("success", Bool.toString success), + ("elapsed_us", encode_time (#elapsed total)), + ("cpu_us", encode_time (#cpu total)), + ("gc_us", encode_time (#gc total)) ] val body = Fine_Grained_Timing_Accumulator.encode (Fine_Grained_Timing_Accumulator.value statistics) + val text = YXML.string_of_body body in - Context_Position.report_text ctxt position - ("fine_grained_timing", properties) (YXML.string_of_body body) + (case Report_Observer.get ctxt of + SOME observe => observe position properties text + | NONE => + Context_Position.report_text ctxt position + ("fine_grained_timing", properties) text) end (* `timing_threshold_us` gates every sink, not just PIDE: it is the user-facing statement that samples below it are noise. Filtering in the - PIDE sink alone makes `fine_grained_timing_output` trace every + PIDE sink alone would make `fine_grained_timing_output` trace every sub-microsecond sample. *) fun above_threshold ctxt ({timing, ...}: timing_result) = let val threshold = Time.fromMicroseconds (Config.get ctxt timing_threshold_us) @@ -455,6 +482,13 @@ struct fun time_it f = time_it_with_status f (K true) #> apfst fst + fun add_timing (delta: Timing.timing) (total: Timing.timing) : Timing.timing = + { + elapsed = #elapsed total + #elapsed delta, + cpu = #cpu total + #cpu delta, + gc = #gc total + #gc delta + } + fun time_and_report ctxt name producer_enabled f = if not producer_enabled then f () else @@ -556,25 +590,74 @@ struct val statistics = Fine_Grained_Timing_Accumulator.create ("Fine-grained timing invocation " ^ Value.print_int id) + val invocation_timing = + Synchronized.var + ("Fine-grained timing total " ^ Value.print_int id) + Timing.zero val invocation = { id = id, invocation_name = invocation_name, position = Position.thread_data (), - statistics = statistics + statistics = statistics, + timing = invocation_timing } val profiles = PIDE_Profiles.get ctxt val ctxt' = PIDE_Profiles.put (statistics :: profiles) ctxt - in - Seq.make (fn _ => + (* + Every pull can contribute samples: the profiled method may backtrack, + and nested `time` wrappers keep writing to `statistics` while it does. + Reporting after the first pull only would discard everything a caller + reaches by backtracking, so wrap the tail and report again whenever a + pull actually added samples. + + Each report is a complete snapshot of the accumulator and all reports + of one invocation share its id, so a consumer must keep the newest + report per id rather than summing them. The outer timing changes even + when no nested sample clears the threshold, so it is part of the + snapshot state as well. + *) + fun timing_key ({elapsed, cpu, gc}: Timing.timing) = + (Time.toMicroseconds elapsed, + Time.toMicroseconds cpu, + Time.toMicroseconds gc) + fun report succeeded + (reported_samples, reported_success, reported_timing) = let - val output = Seq.pull (make_sequence ctxt') - val success = - (case output of - NONE => false - | SOME (element, _) => element_success element) - val _ = emit_pide_report ctxt' invocation success - in output end) - end + val samples = + Fine_Grained_Timing_Accumulator.total_samples + (Fine_Grained_Timing_Accumulator.value statistics) + val current_timing = + timing_key (Synchronized.value invocation_timing) + in + if samples = reported_samples andalso + reported_success = SOME succeeded andalso + reported_timing = SOME current_timing + then (reported_samples, reported_success, reported_timing) + else + (emit_pide_report ctxt' invocation succeeded; + (samples, SOME succeeded, SOME current_timing)) + end + fun wrap succeeded reported make = + Seq.make (fn _ => + let + val (pull_timing, output) = + time_it (fn _ => Seq.pull (make ())) () + val _ = + Synchronized.change invocation_timing + (add_timing pull_timing) + val succeeded' = + succeeded orelse + (case output of + NONE => false + | SOME (element, _) => element_success element) + val reported' = report succeeded' reported + in + Option.map + (fn (element, tail) => + (element, wrap succeeded' reported' (fn _ => tail))) + output + end) + in wrap false (~1, NONE, NONE) (fn _ => make_sequence ctxt') end fun profile_tactic invocation_name ctxt make_tactic state = profile_seq (K true) invocation_name ctxt @@ -629,7 +712,7 @@ in (Method.setup @{binding "profile"} (parser >> (fn (name, method) => fn _ => Fine_Grained_Timing.profile_method name method)) - "profile a method and emit one bundled fine-grained timing report") + "profile a method and emit bundled fine-grained timing snapshots") val _ = Theory.setup (Method.setup @{binding "time"} diff --git a/Fine_Grained_Timing_Panel/src/FineGrainedTiming.scala b/Fine_Grained_Timing_Panel/src/FineGrainedTiming.scala index 4da3de19..37f9e7e8 100644 --- a/Fine_Grained_Timing_Panel/src/FineGrainedTiming.scala +++ b/Fine_Grained_Timing_Panel/src/FineGrainedTiming.scala @@ -71,7 +71,67 @@ object FineGrainedTiming { success: Boolean, timing: Option[Timing], samples: Vector[Sample] - ) + ) { + /* Nested samples may overlap, so their aggregate times cannot be added to + obtain the invocation's wall time. New schema 2 producers carry an + explicit outer timing; older reports leave this empty. */ + def totalTiming: Option[Timing] = timing + + def totalElapsedMicros: Long = + totalTiming.map(_.elapsedMicros).getOrElse(0L) + } + + private def sampleCount(invocation: Invocation): Long = + invocation.samples.iterator.map(_.aggregate.count).sum + + private def timingExtent(invocation: Invocation): (Long, Long, Long) = + invocation.timing match { + case Some(timing) => + (timing.elapsedMicros, timing.cpuMicros, timing.gcMicros) + case None => (-1L, -1L, -1L) + } + + private def laterTiming( + candidate: Invocation, + existing: Invocation + ): Boolean = { + val (candidateElapsed, candidateCpu, candidateGc) = + timingExtent(candidate) + val (existingElapsed, existingCpu, existingGc) = + timingExtent(existing) + candidateElapsed > existingElapsed || + candidateElapsed == existingElapsed && + (candidateCpu > existingCpu || + candidateCpu == existingCpu && candidateGc > existingGc) + } + + private def supersedes(candidate: Invocation, existing: Invocation): Boolean = { + val candidateSamples = sampleCount(candidate) + val existingSamples = sampleCount(existing) + candidateSamples > existingSamples || + (candidateSamples == existingSamples && + (candidate.success && !existing.success || + candidate.success == existing.success && + laterTiming(candidate, existing))) + } + + /* A profile re-reports as its caller pulls more results. Every report of one + invocation carries the same id and a complete snapshot. Keep the snapshot + with the most samples, then the latest outcome and outer timing. */ + def latestPerInvocation( + invocations: Iterable[Invocation] + ): Vector[Invocation] = + invocations.iterator + .foldLeft(Map.empty[Long, Invocation]) { (result, invocation) => + result.updatedWith(invocation.id) { + case Some(existing) if !supersedes(invocation, existing) => + Some(existing) + case _ => Some(invocation) + } + } + .values + .toVector + .sortBy(_.id) final case class SampleKey(name: String, success: Boolean) @@ -111,13 +171,18 @@ object FineGrainedTiming { version: Int, properties: Properties.T ): Option[Option[Timing]] = - if (version == SchemaVersion) Some(None) - else { - for { - elapsed <- longProperty(properties, "elapsed_us") - cpu <- longProperty(properties, "cpu_us") - gc <- longProperty(properties, "gc_us") - } yield Some(Timing(elapsed, cpu, gc)) + { + val names = List("elapsed_us", "cpu_us", "gc_us") + val present = names.count(name => Properties.get(properties, name).isDefined) + if (version == SchemaVersion && present == 0) Some(None) + else if (present != names.length) None + else { + for { + elapsed <- longProperty(properties, "elapsed_us") + cpu <- longProperty(properties, "cpu_us") + gc <- longProperty(properties, "gc_us") + } yield Some(Timing(elapsed, cpu, gc)) + } } private def normalizeBody(body: XML.Body): XML.Body = diff --git a/Fine_Grained_Timing_Panel/src/FineGrainedTimingDockable.scala b/Fine_Grained_Timing_Panel/src/FineGrainedTimingDockable.scala index bde562ba..77bd552d 100644 --- a/Fine_Grained_Timing_Panel/src/FineGrainedTimingDockable.scala +++ b/Fine_Grained_Timing_Panel/src/FineGrainedTimingDockable.scala @@ -602,18 +602,26 @@ extends JPanel(new BorderLayout) with DefaultFocusComponent { offset: Int ): Vector[FineGrainedTiming.Invocation] = { val range = Text.Range(offset, offset + command.length) - snapshot - .select[FineGrainedTiming.Invocation]( - range, - Markup.Elements(FineGrainedTiming.ReportMarkup), - _ => { - case Text.Info(_, tree) => FineGrainedTiming.decode(tree) - } - ) - .iterator - .map(_.info) - .toVector - .distinct + /* `select` keeps only the last markup element of a given name per + markup-tree entry, and every report of one command shares + `Position.thread_data`, so all of them land in a single entry: a + command that opens several profiles — nested ones, or + `apply (crush_base ..., crush_base ...)` — showed just one. + `cumulate` accumulates the whole entry instead. */ + val decoded = + snapshot + .cumulate[Vector[FineGrainedTiming.Invocation]]( + range, + Vector.empty, + Markup.Elements(FineGrainedTiming.ReportMarkup), + _ => { case (found, Text.Info(_, tree)) => + FineGrainedTiming.decode(tree).map(found :+ _) + } + ) + .iterator + .flatMap(_.info) + .toVector + FineGrainedTiming.latestPerInvocation(decoded) } private def makeRenderState( @@ -875,7 +883,7 @@ extends JPanel(new BorderLayout) with DefaultFocusComponent { .filter(visible => invocationVisible(visible.invocation, options.thresholdMicros)) .sortBy(visible => - -visible.invocation.timing.map(_.elapsedMicros).getOrElse(0L)) + -visible.invocation.totalElapsedMicros) .map { visible => val invocation = visible.invocation val location = @@ -956,7 +964,7 @@ extends JPanel(new BorderLayout) with DefaultFocusComponent { ): Vector[String] = { val sampleCount = invocation.samples.iterator.map(_.aggregate.count).sum val elapsed = - invocation.timing.map(timing => formatMicros(timing.elapsedMicros, digits)) + invocation.totalTiming.map(timing => formatMicros(timing.elapsedMicros, digits)) Vector( location, invocation.method, @@ -1007,9 +1015,10 @@ extends JPanel(new BorderLayout) with DefaultFocusComponent { invocation: FineGrainedTiming.Invocation, thresholdMicros: Double ): Boolean = - invocation.timing.forall( - _.elapsedMicros.toDouble >= thresholdMicros - ) + /* Old schema 2 reports have no outer timing. Their total is unknown, not + zero, so retain them rather than hiding otherwise decodable heaps. */ + invocation.totalTiming.forall( + _.elapsedMicros.toDouble >= thresholdMicros) private def commandVisible( view: FineGrainedTimingHierarchy.View, diff --git a/Fine_Grained_Timing_Panel/test/FineGrainedTimingTest.scala b/Fine_Grained_Timing_Panel/test/FineGrainedTimingTest.scala index d5f56c76..89a892b6 100644 --- a/Fine_Grained_Timing_Panel/test/FineGrainedTimingTest.scala +++ b/Fine_Grained_Timing_Panel/test/FineGrainedTimingTest.scala @@ -43,7 +43,9 @@ object FineGrainedTimingTest { private def report( version: Int, - body: XML.Body + body: XML.Body, + invocationTiming: Option[FineGrainedTiming.Timing] = None, + success: Boolean = true ): XML.Tree = XML.Elem( Markup( @@ -52,15 +54,20 @@ object FineGrainedTimingTest { "version" -> Value.Int(version), "invocation" -> Value.Long(17L), "method" -> "example_method", - "success" -> Value.Boolean(true) + "success" -> Value.Boolean(success) ) ++ (if (version == FineGrainedTiming.LegacySchemaVersion) - List( - "elapsed_us" -> Value.Long(100L), - "cpu_us" -> Value.Long(60L), - "gc_us" -> Value.Long(10L) - ) - else Nil) + List( + "elapsed_us" -> Value.Long(100L), + "cpu_us" -> Value.Long(60L), + "gc_us" -> Value.Long(10L) + ) + else invocationTiming.toList.flatMap(timing => + List( + "elapsed_us" -> Value.Long(timing.elapsedMicros), + "cpu_us" -> Value.Long(timing.cpuMicros), + "gc_us" -> Value.Long(timing.gcMicros) + ))) ), body ) @@ -79,7 +86,8 @@ object FineGrainedTimingTest { requireThat(nested == encoded, "nested and YXML-text bodies should decode identically") val invocation = nested.getOrElse(sys.error("expected a decoded invocation")) requireThat(invocation.id == 17L, s"unexpected invocation id ${invocation.id}") - requireThat(invocation.timing.isEmpty, "version 2 should not contain implicit outer timing") + requireThat(invocation.timing.isEmpty, + "schema 2 without outer timing should remain valid") requireThat(invocation.samples.head.aggregate.count == 3L, "sample count was not decoded") } @@ -142,11 +150,88 @@ object FineGrainedTimingTest { "empty aggregate should be an additive identity") } + private def testSchemaTwoUsesOuterTiming(): Unit = { + val outer = FineGrainedTiming.Timing(70L, 40L, 5L) + val decoded = FineGrainedTiming.decode(report( + FineGrainedTiming.SchemaVersion, + List( + entry("first", success = true, 2L, 40L, List(bucket(5, 2))), + entry("second", success = true, 1L, 60L, List(bucket(5, 1))) + ), + invocationTiming = Some(outer) + )) + requireThat(decoded.isDefined, "schema 2 report should decode") + val invocation = decoded.get + requireThat(invocation.totalTiming.contains(outer), + s"schema 2 should use its outer timing, got ${invocation.totalTiming}") + requireThat(invocation.totalElapsedMicros == 70L, + s"nested samples must not be added, got ${invocation.totalElapsedMicros}") + + val legacySchemaTwo = FineGrainedTiming.decode(report( + FineGrainedTiming.SchemaVersion, + List(entry("sample", success = true, 1L, 60L, List(bucket(5, 1)))) + )).get + requireThat(legacySchemaTwo.totalTiming.isEmpty, + "schema 2 reports without an outer timing should remain decodable") + } + + private def testRepeatedSnapshotsKeepTheLatest(): Unit = { + def snapshot(count: Long, elapsed: Long) = + FineGrainedTiming.decode(report( + FineGrainedTiming.SchemaVersion, + List(entry("step", success = true, count, elapsed, List(bucket(5, count)))) + )).get + + val partial = snapshot(1L, 10L) + val complete = snapshot(3L, 90L) + /* Both snapshots share invocation id 17: the later one supersedes the + earlier rather than adding to it. */ + val kept = FineGrainedTiming.latestPerInvocation(Vector(partial, complete)) + requireThat(kept.length == 1, + s"snapshots of one invocation should collapse, got ${kept.length}") + requireThat(kept.head.samples.head.aggregate.count == 3L, + s"the largest snapshot should win, got ${kept.head.samples.head.aggregate.count}") + + val reordered = FineGrainedTiming.latestPerInvocation(Vector(complete, partial)) + requireThat(reordered.head.samples.head.aggregate.count == 3L, + "collapsing must not depend on report order") + + val failed = partial.copy(success = false) + val successful = partial.copy(success = true) + val latestOutcome = + FineGrainedTiming.latestPerInvocation(Vector(failed, successful)) + requireThat(latestOutcome.head.success, + "success should supersede failure when sample counts are equal") + + val earlyTiming = + partial.copy(timing = Some(FineGrainedTiming.Timing(10L, 5L, 0L))) + val lateTiming = + partial.copy(timing = Some(FineGrainedTiming.Timing(90L, 20L, 1L))) + val latestTiming = + FineGrainedTiming.latestPerInvocation(Vector(earlyTiming, lateTiming)) + requireThat(latestTiming.head.timing == lateTiming.timing, + "outer timing should supersede an otherwise equal snapshot") + } + + private def testDistinctInvocationsAreKept(): Unit = { + val first = FineGrainedTiming.decode(report( + FineGrainedTiming.SchemaVersion, + List(entry("a", success = true, 1L, 10L, List(bucket(3, 1)))) + )).get + val second = first.copy(id = 18L) + val kept = FineGrainedTiming.latestPerInvocation(Vector(first, second)) + requireThat(kept.length == 2, + s"distinct invocations must both survive, got ${kept.length}") + } + def main(_args: Array[String]): Unit = { testDecodeNestedAndYxmlBodies() testDecodeLegacyOuterTiming() testRejectMalformedHistogram() testAssociativeMergeAndPercentiles() + testSchemaTwoUsesOuterTiming() + testRepeatedSnapshotsKeepTheLatest() + testDistinctInvocationsAreKept() println("FineGrainedTimingTest: all tests passed") } } diff --git a/ip/fine_timing.py b/ip/fine_timing.py index 555b70a0..4ee3316d 100644 --- a/ip/fine_timing.py +++ b/ip/fine_timing.py @@ -65,6 +65,7 @@ class DecodeResult: malformed: int = 0 unsupported: int = 0 duplicates: int = 0 + superseded: int = 0 class YXMLError(ValueError): @@ -193,7 +194,12 @@ def decode_report(properties, body): version = _integer(properties, "version") if version not in SUPPORTED_VERSIONS: raise UnsupportedVersion(f"unsupported report version {version}") - timing = _timing(properties) if version == 1 else None + timing_names = ("elapsed_us", "cpu_us", "gc_us") + timing = ( + _timing(properties) + if version == 1 or any(name in properties for name in timing_names) + else None + ) return Invocation( version=version, invocation=_integer(properties, "invocation"), @@ -250,6 +256,7 @@ def extract_reports(text, theory="", export_name=""): return result seen = set() + superseded = {} for node, ancestors in _walk(body): properties = None report_body = None @@ -292,6 +299,7 @@ def extract_reports(text, theory="", export_name=""): key = ( theory, invocation.invocation, invocation.method, invocation.success, invocation.command_offset, + _timing_extent(invocation), tuple( (sample.name, sample.success, sample.aggregate.count, sample.aggregate.timing.elapsed_us, @@ -305,12 +313,49 @@ def extract_reports(text, theory="", export_name=""): ) if key in seen: result.duplicates += 1 - else: - seen.add(key) + continue + seen.add(key) + + # A profile re-reports as its caller pulls more results, and each is a + # complete snapshot of the accumulator rather than an increment. The + # snapshots differ, so the content key above does not collapse them; + # keeping them all would count the same samples repeatedly. Retain the + # largest snapshot per invocation instead. + identity = ( + theory, invocation.invocation, invocation.method, + invocation.command_offset, + ) + previous_index = superseded.get(identity) + if previous_index is None: + superseded[identity] = len(result.invocations) result.invocations.append(invocation) + elif _snapshot_extent(invocation) > _snapshot_extent( + result.invocations[previous_index]): + result.invocations[previous_index] = invocation + result.superseded += 1 + else: + result.superseded += 1 return result +def _snapshot_extent(invocation): + """Order snapshots of one invocation; the largest is the final one.""" + return ( + sum(sample.aggregate.count for sample in invocation.samples), + invocation.success, + _timing_extent(invocation), + sum(sample.aggregate.timing.elapsed_us + for sample in invocation.samples), + ) + + +def _timing_extent(invocation): + timing = invocation.timing + if timing is None: + return (-1, -1, -1) + return (timing.elapsed_us, timing.cpu_us, timing.gc_us) + + def merge_aggregate(left, right): histogram = dict(left.histogram) for bucket, count in right.histogram.items(): diff --git a/ip/heap-db-inspect b/ip/heap-db-inspect index d99d8d4f..80eb2d65 100755 --- a/ip/heap-db-inspect +++ b/ip/heap-db-inspect @@ -44,7 +44,7 @@ import sqlite3 import sys from fine_timing import ( - DecodeResult, aggregate_invocations, aggregate_to_json, + DecodeResult, _snapshot_extent, aggregate_invocations, aggregate_to_json, extract_reports, percentile_upper_bound, ) from isar_source import THY_GOALS, collect_keyword_kinds, infer_commands @@ -855,6 +855,7 @@ def read_fine_timing_reports(conn, session, theory=None): result = DecodeResult() seen = set() + superseded = {} missing_decoder = False for theory_name, export_name, blob in conn.execute(query, parameters): text = decompress_blob(blob) @@ -865,10 +866,20 @@ def read_fine_timing_reports(conn, session, theory=None): result.malformed += decoded.malformed result.unsupported += decoded.unsupported result.duplicates += decoded.duplicates + result.superseded += decoded.superseded for invocation in decoded.invocations: key = ( invocation.theory, invocation.invocation, invocation.method, invocation.success, invocation.command_offset, + ( + ( + invocation.timing.elapsed_us, + invocation.timing.cpu_us, + invocation.timing.gc_us, + ) + if invocation.timing is not None + else (-1, -1, -1) + ), tuple( (sample.name, sample.success, sample.aggregate.count, sample.aggregate.timing.elapsed_us, @@ -882,9 +893,24 @@ def read_fine_timing_reports(conn, session, theory=None): ) if key in seen: result.duplicates += 1 - else: - seen.add(key) + continue + seen.add(key) + # Snapshots of one invocation also cross export boundaries; keep + # the largest, as extract_reports does within a single export. + identity = ( + invocation.theory, invocation.invocation, invocation.method, + invocation.command_offset, + ) + previous_index = superseded.get(identity) + if previous_index is None: + superseded[identity] = len(result.invocations) result.invocations.append(invocation) + elif _snapshot_extent(invocation) > _snapshot_extent( + result.invocations[previous_index]): + result.invocations[previous_index] = invocation + result.superseded += 1 + else: + result.superseded += 1 return result, missing_decoder @@ -1060,6 +1086,7 @@ def _fine_summary(result, invocations): "malformed_reports": result.malformed, "unsupported_reports": result.unsupported, "duplicate_reports": result.duplicates, + "superseded_reports": result.superseded, } @@ -1143,11 +1170,13 @@ def show_fine_timing_text(result, invocations, args, unavailable): f"v{version}: {count}" for version, count in sorted(summary["schema_versions"].items())) print(f" Schemas: {versions or '—'}") - if result.malformed or result.unsupported or result.duplicates: + if (result.malformed or result.unsupported or result.duplicates or + result.superseded): print( f" Ignored: {result.malformed} malformed, " f"{result.unsupported} unsupported, " - f"{result.duplicates} duplicate") + f"{result.duplicates} duplicate, " + f"{result.superseded} superseded") if unavailable: print( f" {YELLOW}Source attribution unavailable for " diff --git a/ip/test_fine_timing.py b/ip/test_fine_timing.py index a9c90495..c9ce46ee 100644 --- a/ip/test_fine_timing.py +++ b/ip/test_fine_timing.py @@ -55,7 +55,7 @@ def sample(name="step", success=True, count=3): def transported_report(version=2, invocation=42, success=True, - report_body=None): + report_body=None, invocation_timing=None): properties = { "xml_name": "fine_grained_timing", "version": version, @@ -69,6 +69,12 @@ def transported_report(version=2, invocation=42, success=True, "cpu_us": 400, "gc_us": 10, }) + elif invocation_timing is not None: + properties.update({ + "elapsed_us": invocation_timing.elapsed_us, + "cpu_us": invocation_timing.cpu_us, + "gc_us": invocation_timing.gc_us, + }) return elem( "xml_elem", properties, [elem("xml_body", body=report_body or [sample()]), "apply"]) @@ -107,6 +113,12 @@ def test_decodes_legacy_invocation_timing(self): export_body(transported_report(version=1))) self.assertEqual(result.invocations[0].timing.elapsed_us, 500) + def test_decodes_schema_two_invocation_timing(self): + timing = Timing(70, 40, 5) + result = extract_reports(export_body( + transported_report(invocation_timing=timing))) + self.assertEqual(result.invocations[0].timing, timing) + def test_rejects_bad_histogram(self): bad_sample = sample().replace(Y + "count=3", Y + "count=4", 1) result = extract_reports( @@ -133,6 +145,46 @@ def test_deduplicates_repeated_transport_records(self): self.assertEqual(len(result.invocations), 1) self.assertEqual(result.duplicates, 1) + def test_keeps_only_the_largest_snapshot_of_an_invocation(self): + # A profile re-reports as its caller backtracks. Each report is a + # complete snapshot, so the later one supersedes the earlier rather + # than adding to it. + partial = transported_report(report_body=[sample(count=2)]) + complete = transported_report(report_body=[sample(count=3)]) + result = extract_reports(export_body(partial) + export_body(complete)) + self.assertEqual(len(result.invocations), 1) + self.assertEqual(result.superseded, 1) + self.assertEqual(result.invocations[0].samples[0].aggregate.count, 3) + + reordered = extract_reports( + export_body(complete) + export_body(partial)) + self.assertEqual(len(reordered.invocations), 1) + self.assertEqual( + reordered.invocations[0].samples[0].aggregate.count, 3) + + def test_success_supersedes_failure_with_the_same_samples(self): + failed = transported_report(success=False) + successful = transported_report(success=True) + result = extract_reports(export_body(failed) + export_body(successful)) + self.assertEqual(len(result.invocations), 1) + self.assertTrue(result.invocations[0].success) + + def test_later_timing_supersedes_the_same_samples_and_outcome(self): + early = transported_report( + invocation_timing=Timing(10, 5, 0)) + late = transported_report( + invocation_timing=Timing(90, 20, 1)) + result = extract_reports(export_body(early) + export_body(late)) + self.assertEqual(len(result.invocations), 1) + self.assertEqual(result.invocations[0].timing.elapsed_us, 90) + + def test_distinct_invocations_are_not_collapsed(self): + first = transported_report(invocation=1) + second = transported_report(invocation=2) + result = extract_reports(export_body(first) + export_body(second)) + self.assertEqual(len(result.invocations), 2) + self.assertEqual(result.superseded, 0) + def test_merges_samples_and_preserves_histogram(self): first = extract_reports( export_body(transported_report(invocation=1))).invocations[0] @@ -156,22 +208,27 @@ def test_percentiles_are_bucket_upper_bounds(self): class FineTimingCLITest(unittest.TestCase): + def _database_with_export(self, directory, body): + database = os.path.join(directory, "Example.db") + connection = sqlite3.connect(database) + connection.execute( + "CREATE TABLE isabelle_exports (" + "session_name TEXT, theory_name TEXT, name TEXT, body BLOB)") + connection.execute( + "CREATE TABLE isabelle_sources (" + "session_name TEXT, name TEXT, digest TEXT)") + connection.execute( + "INSERT INTO isabelle_exports VALUES (?, ?, ?, ?)", + ("Example", "Example.Theory", "PIDE/markup", body)) + connection.commit() + connection.close() + return database + def test_json_output_is_machine_readable(self): with tempfile.TemporaryDirectory() as directory: - database = os.path.join(directory, "Example.db") - connection = sqlite3.connect(database) - connection.execute( - "CREATE TABLE isabelle_exports (" - "session_name TEXT, theory_name TEXT, name TEXT, body BLOB)") - connection.execute( - "CREATE TABLE isabelle_sources (" - "session_name TEXT, name TEXT, digest TEXT)") - connection.execute( - "INSERT INTO isabelle_exports VALUES (?, ?, ?, ?)", - ("Example", "Example.Theory", "PIDE/markup", - export_body(transported_report()).encode("utf-8"))) - connection.commit() - connection.close() + database = self._database_with_export( + directory, + export_body(transported_report()).encode("utf-8")) process = subprocess.run( [ @@ -188,6 +245,5 @@ def test_json_output_is_machine_readable(self): self.assertEqual(document["summary"]["reports"], 1) self.assertEqual(document["rows"][0]["sample"], "step") - if __name__ == "__main__": unittest.main() From 4e514771e04992e89c2a74aace2df3c8b376a5a2 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:30 +0100 Subject: [PATCH 23/46] Fine-Grained Timing: Track subgoal blocks in proof scopes Fine-grained timing assigns samples to named Isabelle proofs by parsing the source text. A proof can open a nested `subgoal` block, whose `by` or `done` terminator belongs to that block rather than to the enclosing proof. The parser treated that terminator as the end of the outer proof, leaving a phantom block that could consume the next lemma. Track structured proof blocks and `subgoal` blocks separately. A nested `qed` closes both blocks, while a top-level `qed` ends the named proof. Also recognise `.`, `..`, and `\` as short proof terminators. Partition `global_interpretation` and `subclass` as goal-opening commands, alongside the other commands already recognised by the source parser. Signed-off-by: Hanno Becker --- .../src/FineGrainedTimingScope.scala | 61 +++++++++++++--- .../test/FineGrainedTimingScopeTest.scala | 71 +++++++++++++++++++ 2 files changed, 121 insertions(+), 11 deletions(-) diff --git a/Fine_Grained_Timing_Panel/src/FineGrainedTimingScope.scala b/Fine_Grained_Timing_Panel/src/FineGrainedTimingScope.scala index 2777efbc..f6918252 100644 --- a/Fine_Grained_Timing_Panel/src/FineGrainedTimingScope.scala +++ b/Fine_Grained_Timing_Panel/src/FineGrainedTimingScope.scala @@ -11,8 +11,35 @@ object FineGrainedTimingScope { endOffset: Int ) + /* Every command that opens a goal state, matching the `thy_goal*` keyword + kinds the Python side keys on. `instance`, `interpretation`, `sublocale` + and `termination` carry no name that `ProofNamePattern` can recover, so + `proofName` falls back for them; they were previously attributed to no + proof at all. */ private val NamedProofStarters: Set[String] = - Set("lemma", "theorem", "corollary", "proposition", "schematic_goal") + Set( + "lemma", + "theorem", + "corollary", + "proposition", + "schematic_goal", + "instance", + "interpretation", + "global_interpretation", + "sublocale", + "subclass", + "termination" + ) + + /* Blocks that a proof can nest, distinguished because they close + differently: a structured `proof` block ends at `qed`, while a `subgoal` + block ends at a terminator such as `by` or `done`. */ + private sealed trait ProofBlock + private case object StructuredBlock extends ProofBlock + private case object SubgoalBlock extends ProofBlock + + private val ProofTerminators: Set[String] = + Set("by", "..", ".", "sorry", "\\", "done", "oops") private val ProofNamePattern = """(?s)^\s*(?:lemma|theorem|corollary|proposition|schematic_goal)\s+([A-Za-z0-9_'.]+)""".r @@ -28,19 +55,31 @@ object FineGrainedTimingScope { if (!NamedProofStarters.contains(commands(i).name)) { i += 1 } else { - var depth = 0 + var blocks = List.empty[ProofBlock] var j = i + 1 var endIndex = -1 while (j < commands.length && endIndex < 0) { - commands(j).name match { - case "proof" => - depth += 1 - case "qed" => - if (depth <= 1) endIndex = j - else depth -= 1 - case "by" | "done" | "sorry" | "oops" if depth == 0 => - endIndex = j - case _ => + val name = commands(j).name + if (name == "proof") blocks = StructuredBlock :: blocks + else if (name == "subgoal") blocks = SubgoalBlock :: blocks + else if (name == "qed") { + blocks match { + case Nil => endIndex = j + case List(StructuredBlock) => endIndex = j + case StructuredBlock :: SubgoalBlock :: rest => blocks = rest + case StructuredBlock :: rest => blocks = rest + case _ => + } + } else if (name == "oops") { + endIndex = j + } else if (ProofTerminators.contains(name)) { + blocks match { + /* Closes the enclosing `subgoal`, not the proof. */ + case SubgoalBlock :: rest => blocks = rest + /* Closes a step inside a structured proof; `qed` ends that. */ + case StructuredBlock :: _ => + case Nil => endIndex = j + } } j += 1 } diff --git a/Fine_Grained_Timing_Panel/test/FineGrainedTimingScopeTest.scala b/Fine_Grained_Timing_Panel/test/FineGrainedTimingScopeTest.scala index 0370c561..0a636bf5 100644 --- a/Fine_Grained_Timing_Panel/test/FineGrainedTimingScopeTest.scala +++ b/Fine_Grained_Timing_Panel/test/FineGrainedTimingScopeTest.scala @@ -49,10 +49,81 @@ object FineGrainedTimingScopeTest { ) } + private def testSubgoalBlockDoesNotEndTheProof(): Unit = { + val proofs = FineGrainedTimingScope.partitionNamedProofs(commands( + "lemma", "apply", "subgoal", "by", "apply", "done", + "text" + )) + requireThat(proofs.length == 1, s"expected one named proof, got ${proofs.length}") + requireThat(proofs.head.startIndex == 0 && proofs.head.endIndex == 5, + s"a subgoal block must not terminate the proof: ${proofs.head}") + requireThat(FineGrainedTimingScope.namedProofAt(proofs, 4).contains(proofs.head), + "a command after the subgoal block still belongs to the proof") + } + + private def testNestedSubgoalInStructuredProof(): Unit = { + val proofs = FineGrainedTimingScope.partitionNamedProofs(commands( + "lemma", "proof", "subgoal", "by", "show", "by", "qed" + )) + requireThat(proofs.length == 1, s"expected one named proof, got ${proofs.length}") + requireThat(proofs.head.endIndex == 6, + s"structured proof with a subgoal must end at qed: ${proofs.head}") + } + + private def testStructuredProofClosesItsSubgoalBlock(): Unit = { + val proofs = FineGrainedTimingScope.partitionNamedProofs(commands( + "lemma", + "apply", + "subgoal", "premises", "proof", "show", "by", "qed", + "apply", "done", + "lemma", "by" + )) + requireThat(proofs.length == 2, + s"expected two named proofs, got ${proofs.length}") + requireThat(proofs.head.startIndex == 0 && proofs.head.endIndex == 9, + s"qed must close its structured proof and subgoal: ${proofs.head}") + requireThat(proofs(1).startIndex == 10 && proofs(1).endIndex == 11, + s"the following proof must remain separate: ${proofs(1)}") + } + + private def testShortProofTerminators(): Unit = { + for (terminator <- Seq("qed", "..", ".", "\\", "oops")) { + val proofs = FineGrainedTimingScope.partitionNamedProofs(commands( + "instance", terminator, + "lemma", "by" + )) + requireThat(proofs.length == 2, + s"$terminator should close an instance proof, got ${proofs.length}") + requireThat(proofs.head.endIndex == 1, + s"$terminator consumed the following proof: ${proofs.head}") + } + } + + private def testGoalStartersBeyondLemma(): Unit = { + for (starter <- Seq( + "instance", + "interpretation", + "global_interpretation", + "sublocale", + "subclass", + "termination" + )) { + val proofs = + FineGrainedTimingScope.partitionNamedProofs(commands(starter, "by")) + requireThat(proofs.length == 1, + s"$starter should open a named proof, got ${proofs.length}") + } + } + def main(_args: Array[String]): Unit = { testNamedProofPartitioning() testIncompleteNamedProofIsExcluded() testQualifiedProofName() + testSubgoalBlockDoesNotEndTheProof() + testNestedSubgoalInStructuredProof() + testStructuredProofClosesItsSubgoalBlock() + testShortProofTerminators() + testGoalStartersBeyondLemma() println("FineGrainedTimingScopeTest: all tests passed") } } From a3e3cc5eec4e442e3239bdbbef4a9cd28ee522de Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:31 +0100 Subject: [PATCH 24/46] I/R: Don't cap zstd decompression of PIDE exports The I/R tools read compressed PIDE markup exports to reconstruct source locations and fine-grained timing data. The Python zstandard decoder limited decompressed output to 50 MiB, although large exports can exceed that size and their frame headers often omit the decompressed size. Use an incremental decoder without a fixed output limit and require its end-of-frame marker. Distinguish an unavailable decoder from a corrupt or incomplete frame. Continue processing healthy fine-timing exports when one export is corrupt, and report skipped exports in text and JSON output. A missing decoder still aborts decoding because it affects every compressed export. Report `/timings` failures without terminating the I/R server, and let `/source-map` continue without timing annotations. The Python zstandard path was not exercised with the real module because it is not installed in this environment. Tests cover its end-of-file contract with a stand-in and exercise the command-line fallback classification. Signed-off-by: Hanno Becker --- ip/fine_timing.py | 1 + ip/heap-db-inspect | 77 +++++++++++------ ip/test_blob_decode.py | 190 +++++++++++++++++++++++++++++++++++++++++ ir/heap_info.py | 42 +++++++-- ir/repl_srv.py | 13 ++- 5 files changed, 285 insertions(+), 38 deletions(-) create mode 100644 ip/test_blob_decode.py diff --git a/ip/fine_timing.py b/ip/fine_timing.py index 4ee3316d..ba47fa3b 100644 --- a/ip/fine_timing.py +++ b/ip/fine_timing.py @@ -66,6 +66,7 @@ class DecodeResult: unsupported: int = 0 duplicates: int = 0 superseded: int = 0 + decode_failures: list = field(default_factory=list) class YXMLError(ValueError): diff --git a/ip/heap-db-inspect b/ip/heap-db-inspect index 80eb2d65..63852e61 100755 --- a/ip/heap-db-inspect +++ b/ip/heap-db-inspect @@ -56,6 +56,7 @@ from heap_info import ( isabelle_getenv, resolve_path, file_sha1, is_system_source, decompress_blob, parse_yxml_records, decode_yxml_props, fmt_time, SourceChecker, file_lines, offset_to_line, + BlobDecodeError, ZstdDecoderUnavailable, ZstdDecodeError, _isabelle_env_cache, ) @@ -89,6 +90,15 @@ def section(title): print(f"{'─' * 60}") +def blob_decode_error(kind, error): + if isinstance(error, ZstdDecoderUnavailable): + return ( + f"install Python 'zstandard' or the 'zstd' command " + f"to decode {kind}" + ) + return f"could not decode {kind}: {error}" + + def show_build(conn, session): row = conn.execute( "SELECT return_code, uuid, sources, session_timing, " @@ -340,8 +350,6 @@ def read_command_timings(conn, session): return [] text = decompress_blob(blob[0]) - if text is None: - return None return parse_yxml_records(text) @@ -712,10 +720,6 @@ def show_timings(conn, session, top_n, theory=None, checker=None, with_system=False, records=None, isabelle="isabelle"): if records is None: records = read_command_timings(conn, session) - if records is None: - print(f"\n {YELLOW}Install Python 'zstandard' or the 'zstd' command " - f"to decode command timings{RESET}") - return if not records: return @@ -856,11 +860,15 @@ def read_fine_timing_reports(conn, session, theory=None): result = DecodeResult() seen = set() superseded = {} - missing_decoder = False for theory_name, export_name, blob in conn.execute(query, parameters): - text = decompress_blob(blob) - if text is None: - missing_decoder = True + try: + text = decompress_blob(blob) + except ZstdDecoderUnavailable: + raise + except ZstdDecodeError as error: + result.decode_failures.append( + f"{theory_name}:{export_name}: {error}" + ) continue decoded = extract_reports(text, theory_name, export_name) result.malformed += decoded.malformed @@ -911,7 +919,7 @@ def read_fine_timing_reports(conn, session, theory=None): result.superseded += 1 else: result.superseded += 1 - return result, missing_decoder + return result def _theory_source(checker, theory): @@ -1087,6 +1095,7 @@ def _fine_summary(result, invocations): "unsupported_reports": result.unsupported, "duplicate_reports": result.duplicates, "superseded_reports": result.superseded, + "failed_exports": len(result.decode_failures), } @@ -1109,6 +1118,7 @@ def fine_timing_json(session, result, invocations, args): "view": args.fine_view, "group_by": args.fine_group_by, "summary": _fine_summary(result, invocations), + "failed_exports": result.decode_failures, } if args.fine_view == "calls": rows = [] @@ -1170,6 +1180,11 @@ def show_fine_timing_text(result, invocations, args, unavailable): f"v{version}: {count}" for version, count in sorted(summary["schema_versions"].items())) print(f" Schemas: {versions or '—'}") + if result.decode_failures: + print( + f" {YELLOW}Skipped {len(result.decode_failures)} undecodable " + f"PIDE markup export(s).{RESET}" + ) if (result.malformed or result.unsupported or result.duplicates or result.superseded): print( @@ -1254,9 +1269,6 @@ def show_ml_stats(conn, session): return text = decompress_blob(blob[0]) - if text is None: - print(f"\n {YELLOW}Install 'zstandard' to decode ML statistics{RESET}") - return records = parse_yxml_records(text) if not records: return @@ -1454,21 +1466,28 @@ def main(): print(f" {var} = {RED}(unset){RESET}") ws = args.with_system_sources - timing_records = ( - read_command_timings(conn, session) - if command_timing_requested else None) + try: + timing_records = ( + read_command_timings(conn, session) + if command_timing_requested else None) + except BlobDecodeError as error: + conn.close() + sys.exit(f"{RED}Error: {blob_decode_error('command timings', error)}" + f"{RESET}") fine_result = None fine_invocations = None fine_unavailable = set() if args.fine_timings: - fine_result, missing_decoder = read_fine_timing_reports( - conn, session, theory=args.theory) - if missing_decoder: + try: + fine_result = read_fine_timing_reports( + conn, session, theory=args.theory) + except BlobDecodeError as error: conn.close() sys.exit( - f"{RED}Error: install Python 'zstandard' or the 'zstd' " - f"command to decode PIDE markup exports{RESET}") + f"{RED}Error: " + f"{blob_decode_error('PIDE markup exports', error)}" + f"{RESET}") fine_unavailable = annotate_fine_timing_locations( fine_result.invocations, checker, session, args.isabelle, need_proofs=args.fine_group_by == "proof") @@ -1508,11 +1527,6 @@ def main(): for name, digest in mismatched: print(f" {RED}✗{RESET} {RED}{name:{max_name}s}{RESET} {DIM}{digest}{RESET}") try: - if ((args.timing_range or args.annotate_source) and - timing_records is None): - raise ValueError( - "Install Python 'zstandard' or the 'zstd' command to " - "decode command timings") if args.timing_range: show_timing_range(timing_records, checker, args.timing_range) if args.annotate_source: @@ -1530,7 +1544,14 @@ def main(): if args.fine_timings: show_fine_timing_text( fine_result, fine_invocations, args, fine_unavailable) - if args.ml_stats: show_ml_stats(conn, session) + if args.ml_stats: + try: + show_ml_stats(conn, session) + except BlobDecodeError as error: + conn.close() + sys.exit( + f"{RED}Error: " + f"{blob_decode_error('ML statistics', error)}{RESET}") if args.sources: show_sources_full(conn, session, grep=args.grep, checker=checker, with_system=ws) elif args.source_summary: show_sources_summary(conn, session, with_system=ws) diff --git a/ip/test_blob_decode.py b/ip/test_blob_decode.py new file mode 100644 index 00000000..f88de186 --- /dev/null +++ b/ip/test_blob_decode.py @@ -0,0 +1,190 @@ +#!/usr/bin/env python3 + +import os +import sqlite3 +import subprocess +import sys +import tempfile +import unittest +from unittest.mock import patch + + +HERE = os.path.dirname(os.path.abspath(__file__)) +sys.path.insert(0, os.path.join(HERE, "..", "ir")) + +import heap_info # noqa: E402 +import repl_srv # noqa: E402 + + +X = "\x05" +Y = "\x06" + + +def yxml_element(name, properties=None, body=None): + attributes = "".join( + Y + key + "=" + str(value) + for key, value in (properties or {}).items() + ) + return X + Y + name + attributes + X + "".join(body or []) + X + Y + X + + +def timing_export(): + sample = yxml_element( + "fine_grained_timing_entry", + { + "name": "step", + "success": "true", + "count": 1, + "elapsed_us": 10, + "cpu_us": 5, + "gc_us": 0, + "min_elapsed_us": 10, + "max_elapsed_us": 10, + }, + [yxml_element( + "fine_grained_timing_bucket", + {"bucket": 3, "count": 1}, + )], + ) + report = yxml_element( + "xml_elem", + { + "xml_name": "fine_grained_timing", + "version": 2, + "invocation": 1, + "method": "example", + "success": "true", + "elapsed_us": 20, + "cpu_us": 10, + "gc_us": 0, + }, + [yxml_element("xml_body", body=[sample]), "apply"], + ) + return yxml_element("command_range", body=[report]).encode("utf-8") + + +class BlobDecodeTest(unittest.TestCase): + class FakeZstd: + class ZstdError(Exception): + pass + + class ZstdDecompressor: + def decompressobj(self): + return BlobDecodeTest.IncompleteDecoder() + + class IncompleteDecoder: + eof = False + + def decompress(self, _blob): + return b"partial" + + def test_rejects_a_zstd_frame_without_an_end_marker(self): + blob = b"\x28\xb5\x2f\xfdtruncated" + with patch.object(heap_info, "HAS_ZSTD", True), patch.object( + heap_info, "zstandard", self.FakeZstd, create=True + ): + with self.assertRaises(heap_info.ZstdDecodeError): + heap_info.decompress_blob(blob) + + def test_distinguishes_an_absent_decoder(self): + blob = b"\x28\xb5\x2f\xfdcompressed" + with patch.object(heap_info, "HAS_ZSTD", False), patch.object( + heap_info.subprocess, + "run", + side_effect=FileNotFoundError("zstd"), + ): + with self.assertRaises(heap_info.ZstdDecoderUnavailable): + heap_info.decompress_blob(blob) + + @unittest.skipUnless( + heap_info.HAS_ZSTD, + "Python zstandard module is not installed", + ) + def test_real_decoder_rejects_a_truncated_frame(self): + compressed = heap_info.zstandard.ZstdCompressor().compress( + b"complete frame" + ) + with self.assertRaises(heap_info.ZstdDecodeError): + heap_info.decompress_blob(compressed[:-1]) + + +class TimingConsoleTest(unittest.TestCase): + def test_decode_failure_does_not_escape_the_management_command(self): + class BrokenHeapInfo: + def timing_hotspots(self, **_arguments): + raise heap_info.ZstdDecoderUnavailable("no decoder") + + server = object.__new__(repl_srv.Server) + server.heap_info = BrokenHeapInfo() + + result = server._cmd_timings("/timings") + + self.assertIn("Command timings unavailable", result) + self.assertIn("no decoder", result) + + +class BlobDecodeCLITest(unittest.TestCase): + def test_corrupt_zstd_is_not_reported_as_a_missing_decoder(self): + with tempfile.TemporaryDirectory() as directory: + database = os.path.join(directory, "Example.db") + connection = sqlite3.connect(database) + connection.execute( + "CREATE TABLE isabelle_exports (" + "session_name TEXT, theory_name TEXT, name TEXT, body BLOB)") + connection.execute( + "CREATE TABLE isabelle_sources (" + "session_name TEXT, name TEXT, digest TEXT)") + connection.execute( + "INSERT INTO isabelle_exports VALUES (?, ?, ?, ?)", + ( + "Example", + "Example.Theory", + "PIDE/markup", + b"\x28\xb5\x2f\xfdcorrupt", + ), + ) + connection.execute( + "INSERT INTO isabelle_exports VALUES (?, ?, ?, ?)", + ( + "Example", + "Example.Other", + "PIDE/markup1", + timing_export(), + ), + ) + connection.commit() + connection.close() + + binaries = os.path.join(directory, "bin") + os.mkdir(binaries) + zstd = os.path.join(binaries, "zstd") + with open(zstd, "w", encoding="utf-8") as stream: + stream.write("#!/bin/sh\necho corrupt >&2\nexit 1\n") + os.chmod(zstd, 0o700) + environment = dict(os.environ) + environment["PATH"] = binaries + + process = subprocess.run( + [ + sys.executable, + "-S", + os.path.join(HERE, "heap-db-inspect"), + database, + "--fine-timings", + ], + capture_output=True, + text=True, + env=environment, + ) + + self.assertEqual(process.returncode, 0) + self.assertIn( + "Skipped 1 undecodable PIDE markup export", + process.stdout, + ) + self.assertIn("(1 successful, 0 failed)", process.stdout) + self.assertNotIn("install Python", process.stdout) + + +if __name__ == "__main__": + unittest.main() diff --git a/ir/heap_info.py b/ir/heap_info.py index 14b95965..1ac1dca7 100644 --- a/ir/heap_info.py +++ b/ir/heap_info.py @@ -18,6 +18,18 @@ HAS_ZSTD = False +class BlobDecodeError(RuntimeError): + """A compressed heap database field could not be decoded.""" + + +class ZstdDecoderUnavailable(BlobDecodeError): + """Neither the Python module nor the zstd command is available.""" + + +class ZstdDecodeError(BlobDecodeError): + """A decoder was available, but the zstd frame was invalid.""" + + # --------------------------------------------------------------------------- # Isabelle environment and path resolution # --------------------------------------------------------------------------- @@ -190,16 +202,35 @@ def decompress_blob(blob): return "" if blob[:4] == b'\x28\xb5\x2f\xfd': # zstd magic if HAS_ZSTD: - data = zstandard.ZstdDecompressor().decompress( - blob, max_output_size=50*1024*1024) + try: + decoder = zstandard.ZstdDecompressor().decompressobj() + data = decoder.decompress(blob) + if not decoder.eof: + raise ZstdDecodeError( + "zstd frame ended before its end marker" + ) + except zstandard.ZstdError as error: + raise ZstdDecodeError( + f"invalid zstd frame: {error}" + ) from error else: try: process = subprocess.run( ["zstd", "-q", "-d", "-c"], input=blob, capture_output=True, check=True) data = process.stdout - except (OSError, subprocess.CalledProcessError): - return None # signal missing decoder + except OSError as error: + raise ZstdDecoderUnavailable( + "install Python 'zstandard' or the 'zstd' command" + ) from error + except subprocess.CalledProcessError as error: + detail = error.stderr.decode( + "utf-8", errors="replace" + ).strip() + raise ZstdDecodeError( + "invalid zstd frame" + + (f": {detail}" if detail else "") + ) from error return data.decode("utf-8", errors="replace") return blob.decode("utf-8", errors="replace") if isinstance(blob, bytes) else blob @@ -405,9 +436,6 @@ def _ensure_timing_records(self): self._timing_records = [] return self._timing_records text = decompress_blob(blob[0]) - if text is None: - self._timing_records = [] - return self._timing_records records = parse_yxml_records(text) # Filter out system sources self._timing_records = [ diff --git a/ir/repl_srv.py b/ir/repl_srv.py index fb0ab8e9..809b40aa 100644 --- a/ir/repl_srv.py +++ b/ir/repl_srv.py @@ -73,6 +73,7 @@ import socket import subprocess import threading +from heap_info import BlobDecodeError # Ensure stdout/stderr are unbuffered so parent processes reading our # output via pipes see lines immediately. @@ -1344,8 +1345,11 @@ def _cmd_timings(self, text): m = re.search(r'--theory\s+"([^"]*)"', text) if m: file_filter = m.group(1) - return self.heap_info.timing_hotspots( - top_n=top_n, file_filter=file_filter) + try: + return self.heap_info.timing_hotspots( + top_n=top_n, file_filter=file_filter) + except BlobDecodeError as error: + return f"Command timings unavailable: {error}" def _cmd_source_map(self, text, ansi=False): m, err = self._parse_slash( @@ -1371,7 +1375,10 @@ def _cmd_source_map(self, text, ansi=False): # Get timing data timing_by_offset = {} if self.heap_info: - timing_by_offset = self.heap_info.timing_by_offset() + try: + timing_by_offset = self.heap_info.timing_by_offset() + except BlobDecodeError: + pass # Transform pipeline: YXML → ANSI (console) or plain text (TCP) transforms = console_transforms if ansi else tcp_transforms From b4f1f13af1d022721321aff4ae2d2ebd8774b8fc Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 17:48:31 +0100 Subject: [PATCH 25/46] AutoCorrode: Avoid duplicate Isabelle component registrations The AutoCorrode build prepares Isabelle components such as `Word_Lib` and the fine-grained timing panel. Those components may already be registered by the Isabelle installation, by the user, or by another checkout. Registering the local paths unconditionally can add duplicate entries, and installing the timing panel should not modify the registry. Read the installation and user component registries before each build. Reuse a registered path with the requested basename, and register the local candidate only when no such entry exists. Keep panel installation limited to copying the JAR and remove its unused registration target. Signed-off-by: Hanno Becker --- Fine_Grained_Timing_Panel/Makefile | 7 ++--- Makefile | 44 ++++++++++++++++++++++++++++-- 2 files changed, 43 insertions(+), 8 deletions(-) diff --git a/Fine_Grained_Timing_Panel/Makefile b/Fine_Grained_Timing_Panel/Makefile index c7a6e10d..84cbf979 100644 --- a/Fine_Grained_Timing_Panel/Makefile +++ b/Fine_Grained_Timing_Panel/Makefile @@ -38,7 +38,7 @@ RESOURCE_FILES := $(wildcard resources/*) TEST_SOURCES := $(wildcard test/*.scala) TEST_CLASSPATH = $(CLASSES_DIR):$(TEST_CLASSES_DIR):$(JEDIT_JAR):$(ISABELLE_JAR) -.PHONY: all build test session-test register install clean uninstall +.PHONY: all build test session-test install clean uninstall all: build @@ -68,10 +68,7 @@ session-test: $(ISABELLE) build -d "$(FINE_GRAINED_TIMING_DIR)" \ Fine_Grained_Timing_Test -register: - $(ISABELLE) components -u "$(COMPONENT_DIR)" - -install: register $(JAR_FILE) +install: $(JAR_FILE) echo "Installing Fine-Grained Timing plugin to $(INSTALL_DIR)..." mkdir -p $(INSTALL_DIR) @set -eu; \ diff --git a/Makefile b/Makefile index 62e3fb6c..5e1c020a 100644 --- a/Makefile +++ b/Makefile @@ -15,10 +15,49 @@ # Set this to the directory containing the Isabelle2025-2 binary ISABELLE_HOME?=/Applications/Isabelle2025-2.app/bin +ISABELLE_VERSION?=Isabelle2025-2 +ISABELLE?=$(ISABELLE_HOME)/isabelle # Set this to your home directory USER_HOME?=$(HOME) # Set this to where you maintain, or want to maintain, AFP dependencies AFP_COMPONENT_BASE?=./dependencies/afp + +ISABELLE_SYSTEM_COMPONENTS?=$(abspath $(ISABELLE_HOME)/../etc/components) +ISABELLE_USER_COMPONENTS?=$(USER_HOME)/.isabelle/$(ISABELLE_VERSION)/etc/components + +# $(call ensure_registered,,) +# +# Accept a component registered from any checkout. Register the candidate +# directory only when no existing entry has the requested basename. +define ensure_registered + @name='$(1)'; cand='$(2)'; \ + system_comp='$(ISABELLE_SYSTEM_COMPONENTS)'; \ + user_comp='$(ISABELLE_USER_COMPONENTS)'; \ + component_entries() { \ + for comp in "$$system_comp" "$$user_comp"; do \ + [ ! -f "$$comp" ] || cat "$$comp"; \ + done; \ + }; \ + dir=""; \ + if [ -n "$$cand" ]; then dir=$$(cd "$$cand" 2>/dev/null && pwd || true); fi; \ + echo "Checking Isabelle component: $$name ..."; \ + if [ -n "$$dir" ] && component_entries | grep -Fxq "$$dir"; then \ + echo " $$name already registered -- skipping"; \ + elif component_entries | awk -F/ -v n="$$name" '$$NF==n{found=1} END{exit !found}'; then \ + echo " $$name already registered -- skipping"; \ + elif [ -n "$$dir" ]; then \ + echo " registering: $$dir"; \ + $(ISABELLE) components -u "$$dir"; \ + else \ + echo ""; \ + echo "ERROR: Isabelle component '$$name' is not registered and no path was provided."; \ + echo " Set the corresponding component path or register it manually via:"; \ + echo " isabelle components -u "; \ + echo ""; \ + exit 1; \ + fi +endef + # Set this option to accept `sorry`'ed proofs ifdef QUICK_AND_DIRTY ISABELLE_FLAGS += -o quick_and_dirty @@ -49,11 +88,10 @@ register-components: register-afp-components \ register-fine-grained-timing-panel-component register-afp-components: - $(ISABELLE_HOME)/isabelle components -u $(AFP_COMPONENT_BASE)/Word_Lib + $(call ensure_registered,Word_Lib,$(AFP_COMPONENT_BASE)/Word_Lib) register-fine-grained-timing-panel-component: - $(MAKE) -C Fine_Grained_Timing_Panel \ - ISABELLE_HOME=$(ISABELLE_HOME) register + $(call ensure_registered,Fine_Grained_Timing_Panel,./Fine_Grained_Timing_Panel) build: register-components $(ISABELLE_HOME)/isabelle build $(ISABELLE_FLAGS) -d . \ From 72f6719bcc1f50d4bc0eeb44f5fda6e7803b7de7 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Fri, 25 Sep 2026 06:53:03 +0100 Subject: [PATCH 26/46] AutoLocality: Merge sibling dispatchers by dispatch key Sibling theories can register the same locality dispatcher independently. Their per-theory dispatcher names and aliases can therefore differ even though the dispatch key identifies one dispatcher family. Merging the inventories must not reject that valid import. Merge `locality_dispatcher_inventory_entry` values by dispatch key and choose the lexicographically canonical source name and alias. Add boundary checks and a sibling-theory import regression. The dispatch-key table remains the identity of a dispatcher family. Signed-off-by: Hanno Becker --- Autogen/AutoLocality.thy | 52 +++++++-------- .../AutoLocality_Test_Boundaries.thy | 63 +++++++++---------- .../AutoLocality_Test_Sibling_Base.thy | 20 ++++++ .../AutoLocality_Test_Sibling_Left.thy | 17 +++++ .../AutoLocality_Test_Sibling_Merge.thy | 18 ++++++ .../AutoLocality_Test_Sibling_Right.thy | 17 +++++ Autogen/ROOT | 4 ++ 7 files changed, 127 insertions(+), 64 deletions(-) create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Sibling_Base.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Sibling_Left.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Sibling_Merge.thy create mode 100644 Autogen/AutoLocality_Tests/AutoLocality_Test_Sibling_Right.thy diff --git a/Autogen/AutoLocality.thy b/Autogen/AutoLocality.thy index b9dda409..72e35950 100644 --- a/Autogen/AutoLocality.thy +++ b/Autogen/AutoLocality.thy @@ -90,8 +90,8 @@ The following are the main persistent storage entities. \<^verbatim>\RecordLocalityData\. \<^enum> \<^verbatim>\LocalityDispatcherInventory\ is a third \<^verbatim>\Generic_Data\ value. It records which local named simproc - belongs to each dispatcher family. It stores the source name, a canonical - alias, and an origin stamp, but no theorem payload. + belongs to each dispatcher family. It stores the source name and a + canonical alias, but no theorem payload. \<^enum> The named theorem bundles created for each record contain the declaration-time field facts and certificates used by the proof routines. They are ordinary proof-context theorem collections, not a replacement for @@ -1831,7 +1831,6 @@ ML\ else alias0 type locality_dispatcher_inventory_entry = { - origin: stamp, source_name: string, alias: string } @@ -1839,31 +1838,23 @@ ML\ fun merge_locality_dispatcher_inventory_entry dispatch_key (entry0 : locality_dispatcher_inventory_entry, entry1 : locality_dispatcher_inventory_entry) = - if #origin entry0 <> #origin entry1 then - error ("Conflicting independent AutoLocality dispatchers for " - ^ describe_locality_dispatch_key dispatch_key) - else if #source_name entry0 <> #source_name entry1 then - error ("Inconsistent AutoLocality source dispatcher names for " - ^ describe_locality_dispatch_key dispatch_key) - else - { origin = #origin entry0, - source_name = #source_name entry0, - alias = - canonical_locality_dispatcher_alias - (#alias entry0, #alias entry1) } - - fun insert_locality_dispatcher_alias dispatch_key origin - source_name alias inventory = + { source_name = + canonical_locality_dispatcher_alias + (#source_name entry0, #source_name entry1), + alias = + canonical_locality_dispatcher_alias + (#alias entry0, #alias entry1) } + + fun insert_locality_dispatcher_alias dispatch_key source_name alias + inventory = LocalityDispatchKeyTable.map_default (dispatch_key, - { origin = origin, - source_name = source_name, + { source_name = source_name, alias = alias }) (fn entry => merge_locality_dispatcher_inventory_entry dispatch_key (entry, - { origin = origin, - source_name = source_name, + { source_name = source_name, alias = alias })) inventory @@ -1871,10 +1862,10 @@ ML\ LocalityDispatchKeyTable.join merge_locality_dispatcher_inventory_entry inventories - \\Local inventory of named generic dispatchers. It contains no theorem payload and - no declaration lineage. A private origin stamp distinguishes transport of one standard - declaration from independently allocated sibling dispatchers. One deterministic alias - per family is enough for \<^verbatim>\[[locality_cancel]]\ to restore a representative after + \\Local inventory of named generic dispatchers. It contains no theorem payload + or declaration lineage. One deterministic source name and alias per + dispatch-key family are enough for \<^verbatim>\[[locality_cancel]]\ to restore a + representative after \<^verbatim>\simp only:\ clears the ambient simpset.\ structure LocalityDispatcherInventory = Generic_Data ( @@ -4613,8 +4604,8 @@ ML\ morph_locality_entry_bundle_with (locality_trim_morphism context phi) descriptor facts0 - fun replay_locality_dispatcher_name dispatch_key origin source_name - binding phi context = + fun replay_locality_dispatcher_name dispatch_key source_name binding + phi context = let val ctxt = Context.proof_of context val alias = @@ -4630,7 +4621,7 @@ ML\ in LocalityDispatcherInventory.map (insert_locality_dispatcher_alias - dispatch_key origin source_name alias) context + dispatch_key source_name alias) context end fun ensure_locality_dispatcher dispatch_key lthy = @@ -4665,7 +4656,6 @@ ML\ | (NONE, NONE) => let val binding = locality_simproc_binding dispatch_key - val origin = stamp () val source_name = Local_Theory.full_name lthy binding val identifier = @@ -4680,7 +4670,7 @@ ML\ {pervasive = false, syntax = false, pos = Binding.pos_of binding} (replay_locality_dispatcher_name - dispatch_key origin source_name binding) + dispatch_key source_name binding) val _ = if locality_dispatcher_declared (Context.Proof lthy'') dispatch_key diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Boundaries.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Boundaries.thy index d2ba1399..ec3ae772 100644 --- a/Autogen/AutoLocality_Tests/AutoLocality_Test_Boundaries.thy +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Boundaries.thy @@ -571,7 +571,7 @@ ML\ (fn () => merge_entries (conflict, entry))) ] \ -subsection\Physical dispatcher origins merge strictly\ +subsection\Physical dispatcher families merge by dispatch key\ ML\ val ctxt = \<^context> @@ -581,53 +581,50 @@ ML\ \<^term>\boundary_attr\) val dispatch_key = locality_dispatch_key_of_entry ctxt source_entry - val origin = stamp () - val other_origin = stamp () - - fun singleton key origin source_name alias = + fun singleton key source_name alias = LocalityDispatchKeyTable.update (key, - { origin = origin, - source_name = source_name, + { source_name = source_name, alias = alias } : locality_dispatcher_inventory_entry) LocalityDispatchKeyTable.empty - val same_origin_left = - singleton dispatch_key origin "source" "alias.left" - val same_origin_right = - singleton dispatch_key origin "source" "alias.right" - val merged_same_origin_lr = + val left = + singleton dispatch_key "z.source" "alias.left" + val right = + singleton dispatch_key "a.source" "alias.right" + val merged_lr = merge_locality_dispatcher_inventories - (same_origin_left, same_origin_right) - val merged_same_origin_rl = + (left, right) + val merged_rl = merge_locality_dispatcher_inventories - (same_origin_right, same_origin_left) + (right, left) fun merged_alias inventory = (case LocalityDispatchKeyTable.lookup inventory dispatch_key of SOME entry => #alias entry | NONE => "") - val different_origin = - singleton dispatch_key other_origin "source" "alias.right" - + fun merged_source_name inventory = + (case LocalityDispatchKeyTable.lookup inventory dispatch_key of + SOME entry => #source_name entry + | NONE => "") val _ = AutoLocality_Assert.run_suite - "Boundaries/dispatcher-origin-merge" - [ ("same-origin aliases choose one deterministic representative", + "Boundaries/dispatcher-key-merge" + [ ("same-key names and aliases choose deterministic representatives", + fn () => AutoLocality_Assert.check + "same-key representatives" + (merged_source_name merged_lr = "a.source" + andalso + merged_source_name merged_rl = "a.source" + andalso + merged_alias merged_lr = "alias.left" + andalso + merged_alias merged_rl = "alias.left")), + ("same-key merges retain both branch-independent entries", fn () => AutoLocality_Assert.check - "same-origin representative alias" - (merged_alias merged_same_origin_lr = "alias.left" + "same-key merge" + (LocalityDispatchKeyTable.size merged_lr = 1 andalso - merged_alias merged_same_origin_rl = "alias.left")), - ("independent origins reject left-first", - fn () => AutoLocality_Assert.assert_raises - "independent dispatcher origin" - (fn () => merge_locality_dispatcher_inventories - (same_origin_left, different_origin))), - ("independent origins reject right-first", - fn () => AutoLocality_Assert.assert_raises - "independent dispatcher origin" - (fn () => merge_locality_dispatcher_inventories - (different_origin, same_origin_left))) ] + LocalityDispatchKeyTable.size merged_rl = 1)) ] \ subsection\Semantic replay is independent of dispatcher inventory\ diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Sibling_Base.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Sibling_Base.thy new file mode 100644 index 00000000..8b092657 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Sibling_Base.thy @@ -0,0 +1,20 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Sibling_Base + imports Autogen.AutoLocality +begin +(*>*) + +datatype_record sibling_dispatch_rec = + sibling_dispatch_a :: nat + sibling_dispatch_b :: nat + +definition sibling_dispatch_attr :: + \sibling_dispatch_rec \ bool\ where + \sibling_dispatch_attr R \ sibling_dispatch_a R > 0\ + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Sibling_Left.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Sibling_Left.thy new file mode 100644 index 00000000..049afc23 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Sibling_Left.thy @@ -0,0 +1,17 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Sibling_Left + imports AutoLocality_Test_Sibling_Base +begin +(*>*) + +locality_init for sibling_dispatch_rec + +locality_lemma for sibling_dispatch_rec: + \sibling_dispatch_attr\ footprint [sibling_dispatch_a] . + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Sibling_Merge.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Sibling_Merge.thy new file mode 100644 index 00000000..05c138ee --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Sibling_Merge.thy @@ -0,0 +1,18 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Sibling_Merge + imports AutoLocality_Test_Sibling_Left AutoLocality_Test_Sibling_Right +begin +(*>*) + +lemma sibling_dispatch_merge: + shows \sibling_dispatch_attr + (update_sibling_dispatch_b f R) = + sibling_dispatch_attr R\ + by (simp only: [[locality_cancel]]) + +(*<*) +end +(*>*) diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Sibling_Right.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Sibling_Right.thy new file mode 100644 index 00000000..16119219 --- /dev/null +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Sibling_Right.thy @@ -0,0 +1,17 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory AutoLocality_Test_Sibling_Right + imports AutoLocality_Test_Sibling_Base +begin +(*>*) + +locality_init for sibling_dispatch_rec + +locality_lemma for sibling_dispatch_rec: + \sibling_dispatch_attr\ footprint [sibling_dispatch_a] . + +(*<*) +end +(*>*) diff --git a/Autogen/ROOT b/Autogen/ROOT index 2d55dd24..9bb1c7a1 100644 --- a/Autogen/ROOT +++ b/Autogen/ROOT @@ -26,6 +26,10 @@ session AutoLocality_Tests in "AutoLocality_Tests" = Autogen + AutoLocality_Test_Diamond_Left AutoLocality_Test_Diamond_Right AutoLocality_Test_Diamond + AutoLocality_Test_Sibling_Base + AutoLocality_Test_Sibling_Left + AutoLocality_Test_Sibling_Right + AutoLocality_Test_Sibling_Merge AutoLocality_Test_Boundaries AutoLocality_Test_Record_Extension AutoLocality_Test_Shapes From d42d44840ee9d2fda06061102f89a7c06ff8df4f Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Fri, 25 Sep 2026 06:53:03 +0100 Subject: [PATCH 27/46] Fine-Grained Timing: Decode entries from mixed reports Reports may mix warnings, nested children, and timing data. Invocations may be reported again after raising. The decoder and heap inspector previously lost that outcome. Decode entry children; preserve malformed and unsupported counts. Carry `raised` through model, text, and JSON. Rank snapshots by samples, then raised outcome, success, and timing. Add tests for mixed children, raised snapshots, and inspection output. Signed-off-by: Hanno Becker --- ip/fine_timing.py | 34 ++++++++++--- ip/heap-db-inspect | 6 ++- ip/test_fine_timing.py | 107 ++++++++++++++++++++++++++++++++++++++++- 3 files changed, 137 insertions(+), 10 deletions(-) diff --git a/ip/fine_timing.py b/ip/fine_timing.py index ba47fa3b..68efed62 100644 --- a/ip/fine_timing.py +++ b/ip/fine_timing.py @@ -50,6 +50,7 @@ class Invocation: success: bool timing: object samples: list + raised: bool = False theory: str = "" export_name: str = "" command: str = "" @@ -118,6 +119,14 @@ def _nodes(body): return [item for item in body if isinstance(item, YXMLNode)] +def _entry_children(body): + return [ + child for child in body + if isinstance(child, YXMLNode) + and child.name == ENTRY_MARKUP + ] + + def _property(properties, name): if name not in properties: raise ReportError(f"missing property {name}") @@ -207,6 +216,10 @@ def decode_report(properties, body): method=_property(properties, "method"), success=_boolean(properties, "success"), timing=timing, + raised=( + _boolean(properties, "raised") + if "raised" in properties else False + ), samples=[ _decode_sample(node) for node in _normalize_report_body(body) ], @@ -250,6 +263,8 @@ def _walk(body, ancestors=()): def extract_reports(text, theory="", export_name=""): """Decode all transported timing reports in one PIDE markup export.""" result = DecodeResult() + if REPORT_MARKUP not in text: + return result try: body = parse_yxml(text) except YXMLError: @@ -276,15 +291,14 @@ def extract_reports(text, theory="", export_name=""): continue report_body = bodies[0].body elif node.name == REPORT_MARKUP: - direct = _normalize_report_body(node.body) - if all(isinstance(child, YXMLNode) and - child.name == ENTRY_MARKUP for child in direct): - properties = node.properties - report_body = direct + properties = node.properties + report_body = node.body if properties is None: continue try: + report_body = _entry_children( + _normalize_report_body(report_body)) invocation = decode_report(properties, report_body) except UnsupportedVersion: result.unsupported += 1 @@ -299,7 +313,8 @@ def extract_reports(text, theory="", export_name=""): ancestors) key = ( theory, invocation.invocation, invocation.method, - invocation.success, invocation.command_offset, + invocation.success, invocation.raised, + invocation.command_offset, _timing_extent(invocation), tuple( (sample.name, sample.success, sample.aggregate.count, @@ -341,9 +356,14 @@ def extract_reports(text, theory="", export_name=""): def _snapshot_extent(invocation): """Order snapshots of one invocation; the largest is the final one.""" + outcome = ( + 2 if invocation.raised + else 1 if invocation.success + else 0 + ) return ( sum(sample.aggregate.count for sample in invocation.samples), - invocation.success, + outcome, _timing_extent(invocation), sum(sample.aggregate.timing.elapsed_us for sample in invocation.samples), diff --git a/ip/heap-db-inspect b/ip/heap-db-inspect index 63852e61..e1583975 100755 --- a/ip/heap-db-inspect +++ b/ip/heap-db-inspect @@ -1078,17 +1078,20 @@ def _display_fine_group(group, group_by, width=56): def _fine_summary(result, invocations): schemas = {} successful = 0 + raised = 0 measurements = 0 for invocation in invocations: schemas[str(invocation.version)] = ( schemas.get(str(invocation.version), 0) + 1) successful += int(invocation.success) + raised += int(invocation.raised) measurements += sum( sample.aggregate.count for sample in invocation.samples) return { "reports": len(invocations), "successful_invocations": successful, "failed_invocations": len(invocations) - successful, + "raised_invocations": raised, "measurements": measurements, "schema_versions": schemas, "malformed_reports": result.malformed, @@ -1130,6 +1133,7 @@ def fine_timing_json(session, result, invocations, args): "schema_version": invocation.version, "method": invocation.method, "success": invocation.success, + "raised": invocation.raised, "timing_us": ( None if invocation.timing is None else { "elapsed": invocation.timing.elapsed_us, @@ -1210,7 +1214,7 @@ def show_fine_timing_text(result, invocations, args, unavailable): f"invocation={invocation.invocation}") print( f" method={invocation.method} " - f"outcome={'success' if invocation.success else 'failure'}") + f"outcome={'raised' if invocation.raised else 'success' if invocation.success else 'failure'}") if invocation.timing is not None: print( f" invocation timing=" diff --git a/ip/test_fine_timing.py b/ip/test_fine_timing.py index c9ce46ee..a2706201 100644 --- a/ip/test_fine_timing.py +++ b/ip/test_fine_timing.py @@ -7,13 +7,16 @@ import sys import tempfile import unittest +from unittest.mock import patch HERE = os.path.dirname(os.path.abspath(__file__)) sys.path.insert(0, HERE) +import fine_timing # noqa: E402 from fine_timing import ( # noqa: E402 - Aggregate, Timing, aggregate_invocations, extract_reports, + Aggregate, REPORT_MARKUP, Timing, YXMLNode, YXMLError, + aggregate_invocations, extract_reports, percentile_upper_bound, ) @@ -55,7 +58,7 @@ def sample(name="step", success=True, count=3): def transported_report(version=2, invocation=42, success=True, - report_body=None, invocation_timing=None): + raised=False, report_body=None, invocation_timing=None): properties = { "xml_name": "fine_grained_timing", "version": version, @@ -63,6 +66,8 @@ def transported_report(version=2, invocation=42, success=True, "method": "example_method", "success": str(success).lower(), } + if raised: + properties["raised"] = "true" if version == 1: properties.update({ "elapsed_us": 500, @@ -139,6 +144,65 @@ def test_handles_deep_pide_markup_without_recursion(self): result = extract_reports(report) self.assertEqual(len(result.invocations), 1) + def test_filters_non_entry_direct_children(self): + mixed = elem( + "fine_grained_timing", + {"version": 2, "invocation": 42, "method": "example_method", + "success": "true"}, + [sample(), elem("unexpected")]) + result = extract_reports(mixed) + self.assertEqual(result.malformed, 0) + self.assertEqual(len(result.invocations), 1) + self.assertEqual(result.invocations[0].samples[0].aggregate.count, 3) + + def test_filters_non_entry_transported_children(self): + mixed = transported_report( + report_body=[sample(), elem("unexpected")]) + result = extract_reports(export_body(mixed)) + self.assertEqual(result.malformed, 0) + self.assertEqual(len(result.invocations), 1) + self.assertEqual(result.invocations[0].samples[0].aggregate.count, 3) + + def test_decodes_string_encoded_transported_body(self): + properties = { + "version": "2", + "invocation": "42", + "method": "example_method", + "success": "true", + } + report = YXMLNode( + "xml_elem", {"xml_name": REPORT_MARKUP, **properties}, [ + YXMLNode("xml_body", {}, [sample()])]) + entry = fine_timing.parse_yxml(sample())[0] + with patch.object( + fine_timing, "parse_yxml", + side_effect=[[report], [entry]]): + result = extract_reports(REPORT_MARKUP) + self.assertEqual(result.malformed, 0) + self.assertEqual(len(result.invocations), 1) + self.assertEqual(result.invocations[0].samples[0].aggregate.count, 3) + + def test_counts_malformed_string_encoded_transported_body(self): + properties = { + "version": "2", + "invocation": "42", + "method": "example_method", + "success": "true", + } + report = YXMLNode( + "xml_elem", {"xml_name": REPORT_MARKUP, **properties}, [ + YXMLNode("xml_body", {}, [X + "malformed body"])]) + with patch.object( + fine_timing, "parse_yxml", + side_effect=[[report], YXMLError("malformed body")]): + result = extract_reports(REPORT_MARKUP) + self.assertEqual(result.malformed, 1) + self.assertEqual(result.invocations, []) + + def test_skips_markup_free_exports(self): + result = extract_reports(elem("command_span", {"name": "apply"})) + self.assertEqual(result, extract_reports("")) + def test_deduplicates_repeated_transport_records(self): report = transported_report() result = extract_reports(report + report) @@ -169,6 +233,15 @@ def test_success_supersedes_failure_with_the_same_samples(self): self.assertEqual(len(result.invocations), 1) self.assertTrue(result.invocations[0].success) + def test_raised_supersedes_success_with_the_same_samples(self): + successful = transported_report(success=True) + raised = transported_report(success=False, raised=True) + result = extract_reports( + export_body(successful) + export_body(raised)) + self.assertEqual(len(result.invocations), 1) + self.assertTrue(result.invocations[0].raised) + self.assertFalse(result.invocations[0].success) + def test_later_timing_supersedes_the_same_samples_and_outcome(self): early = transported_report( invocation_timing=Timing(10, 5, 0)) @@ -245,5 +318,35 @@ def test_json_output_is_machine_readable(self): self.assertEqual(document["summary"]["reports"], 1) self.assertEqual(document["rows"][0]["sample"], "step") + def test_json_and_text_preserve_raised_outcome(self): + with tempfile.TemporaryDirectory() as directory: + database = self._database_with_export( + directory, + export_body(transported_report( + success=False, raised=True)).encode("utf-8")) + + json_process = subprocess.run( + [ + os.path.join(HERE, "heap-db-inspect"), + database, + "--fine-timings", + "--fine-view", "calls", + "--format", "json", + ], + check=True, capture_output=True, text=True) + document = json.loads(json_process.stdout) + self.assertTrue(document["rows"][0]["invocation"]["raised"]) + self.assertEqual(document["summary"]["raised_invocations"], 1) + + text_process = subprocess.run( + [ + os.path.join(HERE, "heap-db-inspect"), + database, + "--fine-timings", + "--fine-view", "calls", + ], + check=True, capture_output=True, text=True) + self.assertIn("outcome=raised", text_process.stdout) + if __name__ == "__main__": unittest.main() From ee2385758d7de8ad08c377ee17957ada46bbf41e Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 24 Sep 2026 16:35:19 +0000 Subject: [PATCH 28/46] AutoCorrode: Use typed artifacts for record generation `micro_rust_record` derives updater, lens, and focus facts for every datatype-record field. The old generator repeatedly resolved field metadata, parsed generated propositions, and opened Isar proof transactions for each equation. Wide records therefore serialized a large amount of repeated preparation. Prepare one typed descriptor and carry constants, definitions, and theorems through the complete generator. Construct update propositions as terms, prove independent equations with `Goal.prove_future`, and consolidate them before registering facts in field order. Define lens and focus constants through `Local_Theory.define`. Keep `micro_rust_record` syntax, generated theorem names and attributes, field registration, localizable instances, and the existing HOL-record path unchanged. This does not alter Isabelle's datatype-record generator. For a synthetic 30-field record, the micro-generation phase fell from 9.447s to 2.405s. Add compatibility checks to `Micro_Rust_Shallow_Embedding_Tests`, including a polymorphic record and a `[no_fields]` record. They check the lens and focus constant types, selected update propositions, the attribute collections each generated fact lands in, field registration, and localizable instances. Signed-off-by: Hanno Becker --- Autogen/AutoLens.thy | 937 ++++++++++++++++-- .../Micro_Rust_Shallow_Embedding.thy | 68 +- .../Micro_Rust_Shallow_Embedding_Tests.thy | 162 +++ 3 files changed, 1067 insertions(+), 100 deletions(-) diff --git a/Autogen/AutoLens.thy b/Autogen/AutoLens.thy index 50b9fb92..837941c5 100644 --- a/Autogen/AutoLens.thy +++ b/Autogen/AutoLens.thy @@ -142,6 +142,107 @@ ML\ \\Update the ith entry of a list\ fun list_set_nth (i : int) (x : 'a) = nth_map i (K x) + \\Generated names shared by every record-autogen phase.\ + fun lens_name rec_name field = rec_name ^ "_" ^ field ^ "_lens" + fun focus_name rec_name field = rec_name ^ "_" ^ field ^ "_focus" + + datatype autolens_record_backend = + AutoLens_Datatype_Record of + {constructor: term, + constructor_simps: thm list, + exhaust: thm, + selector_simps: thm list} + | AutoLens_HOL_Record + + type autolens_field_descriptor = + {index: int, + base_name: string, + selector_name: string, + selector: term, + field_type: typ, + updater_name: string, + updater: term, + updater_def: thm option, + lens_name: string, + focus_name: string} + + type autolens_record_descriptor = + {source_name: string, + type_name: string, + record_type: typ, + backend: autolens_record_backend, + fields: autolens_field_descriptor list, + expand_rules: thm list} + + type autolens_lens_definition_artifact = + {field: autolens_field_descriptor, + lens: term, + lens_def: thm} + + type autolens_lens_components_artifact = + {field: autolens_field_descriptor, + lens: term, + lens_def: thm, + view_modify_valid: thm, + lens_components: thm list} + + type autolens_lens_artifact = + {field: autolens_field_descriptor, + lens: term, + lens_def: thm, + view_modify_valid: thm, + lens_components: thm list, + lens_valid: thm} + + type autolens_update_artifact = + {field: autolens_field_descriptor, + update_explicit: thm, + update_local: thm} + + type autolens_focus_definition_artifact = + {lens_artifact: autolens_lens_artifact, + focus: term, + focus_def: thm} + + type autolens_focus_components_artifact = + {lens_artifact: autolens_lens_artifact, + focus: term, + focus_def: thm, + focus_components: thm list} + + type autolens_focus_artifact = + {field: autolens_field_descriptor, + focus: term, + focus_def: thm, + focus_components: thm list, + focus_code: thm} + + fun check_application ctxt name args = + Syntax.check_term ctxt + (list_comb (Const (name, dummyT), args)) + + fun check_equality_prop ctxt lhs rhs = + Syntax.check_term ctxt + (HOLogic.mk_Trueprop + (Const (\<^const_name>\HOL.eq\, dummyT) $ lhs $ rhs)) + + fun define_typed_constant name rhs lthy = + let + val binding = Binding.qualified_name name + in + Local_Theory.define + ((binding, Mixfix.NoSyn), + ((Thm.def_binding binding, + [Code.singleton_default_equation_attrib]), rhs)) lthy + end + + fun prove_autogen_prop_with ctxt ctxt' asms prop tac = + let + val thm = Goal.prove ctxt' [] asms prop tac + in + Variable.export ctxt' ctxt [thm] |> the_single + end + \\Looks up a datatype record in the given context, and returns the list of fields (fully qualified)\ fun get_fields_full rec_name thy = @@ -207,6 +308,153 @@ ML\ #> extract_const) end + fun specialize_result_type ctxt result_type t = + let + val thy = Proof_Context.theory_of ctxt + val term_type = fastype_of t + val matching_binders = + Term.binder_types term_type + |> filter (fn T => Type.could_unify (T, result_type)) + val matching_types = Term.body_type term_type :: matching_binders + val tyenv = + fold (fn T => Sign.typ_match thy (T, result_type)) + matching_types Vartab.empty + in + Envir.subst_term_types tyenv t + end + + fun specialize_term_type ctxt expected_type t = + let + val thy = Proof_Context.theory_of ctxt + val tyenv = + Sign.typ_match thy (fastype_of t, expected_type) + Vartab.empty + in + Envir.subst_term_types tyenv t + end + + fun defined_const thm = + (case Thm.prop_of thm of + Const (\<^const_name>\Pure.eq\, _) $ lhs $ _ => + SOME (Term.dest_Const (Term.head_of lhs) |> fst) + | _ => NONE) + handle TERM _ => NONE + + fun datatype_updater_defs ctxt = + fold + (fn thm => + (case defined_const thm of + SOME name => Symtab.update (name, thm) + | NONE => I)) + (Named_Theorems.get ctxt + \<^named_theorems>\datatype_record_update\) + Symtab.empty + + fun prepare_record_descriptor rec_name lthy : autolens_record_descriptor = + let + val ctxt = Local_Theory.target_of lthy + val theory = Proof_Context.theory_of ctxt + val raw_record_type = + Proof_Context.read_type_name + {proper = true, strict = false} ctxt rec_name + val (type_name, _) = Term.dest_Type raw_record_type + val selector_names = get_fields_full rec_name lthy + fun read_const name = + Proof_Context.read_const {proper = true, strict = true} ctxt name + fun build_fields updater_def_of selectors updater_names updaters = + let + fun build _ [] [] [] [] = [] + | build index (selector_name :: selector_names) + (selector :: selectors) (updater_name :: updater_names) + (updater :: updaters) = + let + val base_name = Long_Name.base_name selector_name + val updater_name_full = Term.dest_Const updater |> fst + in + {index = index, + base_name = base_name, + selector_name = selector_name, + selector = selector, + field_type = Term.body_type (fastype_of selector), + updater_name = updater_name_full, + updater = updater, + updater_def = updater_def_of updater_name_full, + lens_name = lens_name rec_name base_name, + focus_name = focus_name rec_name base_name} + :: build (index + 1) selector_names selectors updater_names + updaters + end + | build _ _ _ _ _ = + error ("Inconsistent selector/updater metadata for record " + ^ quote rec_name) + in + build 0 selector_names selectors updater_names updaters + end + fun fallback_expand_rules () = + (case try (lookup_thm ctxt) (rec_name ^ ".expand") of + SOME thm => [thm] + | NONE => []) + in + case Ctr_Sugar.ctr_sugar_of ctxt type_name of + SOME sugar => + let + val record_type = #T sugar + val constructor = + (case #ctrs sugar of + [constructor] => constructor + | _ => error ("Expected one constructor for record " + ^ quote rec_name)) + val selectors = + (case #selss sugar of + [selectors] => selectors + | _ => error ("Expected one selector family for record " + ^ quote rec_name)) + val updater_names = + map (prefix "update_" o Long_Name.base_name) selector_names + val updaters = + map (specialize_result_type ctxt record_type o read_const) + updater_names + val updater_defs = datatype_updater_defs ctxt + fun updater_def_of name = Symtab.lookup updater_defs name + val expand_rules = + if null (#expands sugar) then fallback_expand_rules () + else #expands sugar + in + {source_name = rec_name, + type_name = type_name, + record_type = record_type, + backend = AutoLens_Datatype_Record + {constructor = constructor, + constructor_simps = #case_thms sugar, + exhaust = #exhaust sugar, + selector_simps = flat (#sel_thmss sugar)}, + fields = + build_fields updater_def_of + selectors updater_names updaters, + expand_rules = expand_rules} + end + | NONE => + let + val (record_type0, _) = prepare_rec_name ctxt rec_name + val record_type = record_type0 + val updater_names = get_field_updates_full rec_name lthy + val selectors = map read_const selector_names + val updaters = map read_const updater_names + val _ = + if is_some (Record.get_info theory type_name) then () + else error ("Unknown datatype or record type " ^ quote rec_name) + in + {source_name = rec_name, + type_name = type_name, + record_type = record_type, + backend = AutoLens_HOL_Record, + fields = + build_fields (lookup_def_opt ctxt) + selectors updater_names updaters, + expand_rules = fallback_expand_rules ()} + end + end + \\General helpers for interpreting strings as methods and applying them\ val apply_text = (Seq.the_result "initial method") oo ((fn t => (t, Position.no_range)) #> Proof.apply) @@ -236,18 +484,80 @@ text\This section implements the theory transformer \<^verbatim>\len auto-generates lenses for each record field.\ ML\ - \\The name of the lens associated with a record field\ - fun lens_name rec_name field = rec_name ^ "_" ^ field ^ "_lens" + fun prove_view_modify_valid_from + (descriptor : autolens_record_descriptor) + (field : autolens_field_descriptor) lthy = + let + val ([selector, updater], ctxt') = + Variable.importT_terms [#selector field, #updater field] lthy + val validity = + check_application ctxt' + \<^const_name>\is_valid_lens_view_modify\ + [selector, updater] + |> HOLogic.mk_Trueprop + val rules = + Proof_Context.get_thm ctxt' + "is_valid_lens_view_modify_def" + :: #expand_rules descriptor + in + prove_autogen_prop_with lthy ctxt' [] validity + (fn {context, ...} => + asm_full_simp_tac (context addsimps rules) 1) + end - \\Theory transformation adding a single record field lens\ - fun make_lens rec_name field ctxt = let - val update_name = "update_" ^ field - val lens_expr = "make_lens_via_view_modify " ^ field ^ " " ^ update_name in - ctxt |> typeless_def [] (lens_name rec_name field) lens_expr - end + fun define_lens_from + (descriptor : autolens_record_descriptor) + (field : autolens_field_descriptor) lthy = + let + val ([selector, updater], definition_lthy) = + Variable.importT_terms + [#selector field, #updater field] lthy + val rhs = + check_application definition_lthy + \<^const_name>\make_lens_via_view_modify\ + [selector, updater] + val ((lens, (_, lens_def)), lthy') = + define_typed_constant (#lens_name field) rhs definition_lthy + in + ({field = field, + lens = lens, + lens_def = lens_def} + : autolens_lens_definition_artifact, + lthy') + end + + fun lens_autogen_defs_from + (descriptor : autolens_record_descriptor) lthy = + fold_map (define_lens_from descriptor) (#fields descriptor) lthy + + fun lookup_lens_definitions_from + (descriptor : autolens_record_descriptor) lthy = + let + fun lookup field = + let + val lens = + Proof_Context.read_const + {proper = true, strict = true} lthy (#lens_name field) + val lens_def = + Proof_Context.get_thm lthy + (Thm.def_name (#lens_name field)) + in + {field = field, + lens = lens, + lens_def = lens_def} + : autolens_lens_definition_artifact + end + in + map lookup (#fields descriptor) + end \\Theory transformation adding lens definitions for a record\ - fun lens_autogen_defs rec_name thy = fold (make_lens rec_name) (get_fields rec_name thy) thy + fun lens_autogen_defs rec_name lthy = + let + val descriptor = prepare_record_descriptor rec_name lthy + in + lens_autogen_defs_from descriptor lthy |> snd + end \ locale AutoLensExample @@ -271,40 +581,89 @@ end subsubsection\Defining equations\ ML\ - fun prove_defining_eqns_for_lens attribs rec_name field ctxt = let - val lens = lens_name rec_name field - val lens_def = lens |> Thm.def_name - val prop_view_str = "lens_view " ^ lens ^ " = " ^ field - val prop_modify_str = "lens_modify " ^ lens ^ " = update_" ^ field - val prop_update_str = "lens_update " ^ lens ^ " = (\x. update_" ^ field ^ " (\_. x))" - val view_prop = prop_view_str |> Syntax.read_prop ctxt - val modify_prop = prop_modify_str |> Syntax.read_prop ctxt - val update_prop = prop_update_str |> Syntax.read_prop ctxt - val prop_name = lens ^ "_view_update_modify" - fun after_qed name thms ctxt = ctxt - |> Local_Theory.note (name, flat thms) |> snd - |> Local_Theory.note ((Binding.empty,attribs), thms |> flat) |> snd - in - ctxt - |> Proof.theorem NONE - (after_qed ((Binding.name prop_name), [])) - [[(view_prop, [])],[(modify_prop, [])], [(update_prop, [])]] - |> apply_txt ctxt ( - "intro ext; clarsimp simp add: make_lens_via_view_modify_def " ^ lens_def - ) - |> apply_txt ctxt ( - "intro ext; clarsimp simp add: make_lens_via_view_modify_def " ^ lens_def ^ - " lens_modify_def " ^ rec_name ^ ".expand" - ) - |> apply_txt ctxt ( - "intro ext; clarsimp simp add: make_lens_via_view_modify_def " ^ lens_def) - |> Proof.global_done_proof - end + fun make_lens_component_props + (artifact : autolens_lens_definition_artifact) ctxt = + let + val {field, lens, ...} = artifact + val view = + check_application ctxt \<^const_name>\lens_view\ [lens] + val modify = + check_application ctxt \<^const_name>\lens_modify\ [lens] + val update = + check_application ctxt \<^const_name>\lens_update\ [lens] + val selector = + specialize_term_type ctxt (fastype_of view) (#selector field) + val updater = + specialize_term_type ctxt (fastype_of modify) (#updater field) + val (field_type, _) = Term.dest_funT (fastype_of update) + val update_rhs = + Abs ("x", field_type, + updater $ Abs ("_", field_type, Bound 1)) + in + [check_equality_prop ctxt view selector, + check_equality_prop ctxt modify updater, + check_equality_prop ctxt update update_rhs] + end + + fun prove_lens_component lthy lens_def rule core prop = + Goal.prove lthy [] [] prop + (fn {context, ...} => + Local_Defs.unfold_tac context [lens_def] THEN + resolve_tac context [rule] 1 THEN + (case core of + SOME thm => resolve_tac context [thm] 1 + | NONE => all_tac)) + + fun prove_lens_components_from attribs + (descriptor : autolens_record_descriptor) + (artifact : autolens_lens_definition_artifact) lthy = + let + val {field, lens, lens_def} = artifact + val view_modify_valid = + prove_view_modify_valid_from descriptor field lthy + val props = make_lens_component_props artifact lthy + val rules = + Proof_Context.get_thms lthy + "make_lens_via_view_modify_components" + val components = + [prove_lens_component lthy lens_def + (nth rules 0) + NONE (nth props 0), + prove_lens_component lthy lens_def + (nth rules 2) + (SOME view_modify_valid) (nth props 1), + prove_lens_component lthy lens_def + (nth rules 1) + NONE (nth props 2)] + val (_, lthy') = + Local_Theory.note + ((Binding.name (#lens_name field ^ "_view_update_modify"), + attribs), + components) lthy + in + ({field = field, + lens = lens, + lens_def = lens_def, + view_modify_valid = view_modify_valid, + lens_components = components} + : autolens_lens_components_artifact, + lthy') + end + + fun lens_autogen_defining_equations_from attribs + (descriptor : autolens_record_descriptor) artifacts lthy = + fold_map (prove_lens_components_from attribs descriptor) + artifacts lthy \\Theory transformation adding defining equations for all fields of a record.\ - fun lens_autogen_defining_equations attribs rec_name thy = - let val fields = get_fields rec_name thy in - fold (prove_defining_eqns_for_lens attribs rec_name) fields thy + fun lens_autogen_defining_equations attribs rec_name lthy = + let + val descriptor = prepare_record_descriptor rec_name lthy + val artifacts = lookup_lens_definitions_from descriptor lthy + in + lens_autogen_defining_equations_from + attribs descriptor artifacts lthy + |> snd end \ @@ -332,33 +691,90 @@ subsubsection\Lens validity\ text\All auto-generated lenses are valid:\ ML\ - \\States and proves the validity of the auto-generated lens corresponding to a record field.\ - fun prove_lens_validity attribs rec_name field ctxt = let - val lens = lens_name rec_name field - val lens_def = lens |> Thm.def_name - val prop_name = lens ^ "_valid" - val prop_str = "is_valid_lens " ^ lens - val validity_prop = prop_str |> Syntax.read_prop ctxt - fun after_qed name thms ctxt = ctxt - |> Local_Theory.note (name, flat thms) |> snd - |> Local_Theory.note ((Binding.empty, attribs), thms |> flat) |> snd - in - ctxt - |> Proof.theorem NONE - (after_qed ((Binding.name prop_name), [])) - [[(validity_prop, [])]] - |> apply_txt ctxt (String.concatWith ";" - ["unfold " ^ lens_def, - "intro is_valid_lens_via_modifyI'", - "simp add: is_valid_lens_view_modify_def " ^ rec_name ^ ".expand"]) - |> Proof.global_done_proof - end + fun lookup_lens_components_from + (descriptor : autolens_record_descriptor) lthy = + let + val definitions = lookup_lens_definitions_from descriptor lthy + fun lookup + ({field, lens, lens_def} + : autolens_lens_definition_artifact) = + {field = field, + lens = lens, + lens_def = lens_def, + view_modify_valid = + prove_view_modify_valid_from descriptor field lthy, + lens_components = + Proof_Context.get_thms lthy + (#lens_name field ^ "_view_update_modify")} + : autolens_lens_components_artifact + in + map lookup definitions + end + + fun prove_lens_validity_from attribs + (artifact : autolens_lens_components_artifact) lthy = + let + val {field, lens, lens_def, view_modify_valid, lens_components} = + artifact + val validity_prop = + check_application lthy \<^const_name>\is_valid_lens\ [lens] + |> HOLogic.mk_Trueprop + val lens_valid = + Goal.prove lthy [] [] validity_prop + (fn {context, ...} => + Local_Defs.unfold_tac context [lens_def] THEN + resolve_tac context + [Proof_Context.get_thm context + "is_valid_lens_via_modifyI'"] 1 THEN + resolve_tac context [view_modify_valid] 1) + val (_, lthy') = + Local_Theory.note + ((Binding.name (#lens_name field ^ "_valid"), attribs), + [lens_valid]) lthy + in + ({field = field, + lens = lens, + lens_def = lens_def, + view_modify_valid = view_modify_valid, + lens_components = lens_components, + lens_valid = lens_valid} + : autolens_lens_artifact, + lthy') + end + + fun lens_autogen_prove_lens_validity_from attribs + (_ : autolens_record_descriptor) artifacts lthy = + fold_map (prove_lens_validity_from attribs) artifacts lthy + + fun lookup_lens_artifacts_from + (descriptor : autolens_record_descriptor) lthy = + let + val components = lookup_lens_components_from descriptor lthy + fun lookup + ({field, lens, lens_def, view_modify_valid, lens_components} + : autolens_lens_components_artifact) = + {field = field, + lens = lens, + lens_def = lens_def, + view_modify_valid = view_modify_valid, + lens_components = lens_components, + lens_valid = + Proof_Context.get_thm lthy (#lens_name field ^ "_valid")} + : autolens_lens_artifact + in + map lookup components + end \\Theory transformation adding lens validity lemmas\ - fun lens_autogen_prove_lens_validity attribs rec_name thy = - let val fields = get_fields rec_name thy in - fold (prove_lens_validity attribs rec_name) fields thy - end + fun lens_autogen_prove_lens_validity attribs rec_name lthy = + let + val descriptor = prepare_record_descriptor rec_name lthy + val artifacts = lookup_lens_components_from descriptor lthy + in + lens_autogen_prove_lens_validity_from + attribs descriptor artifacts lthy + |> snd + end \ context AutoLensExample @@ -394,8 +810,6 @@ ML\ |> Pretty.symbolic_string_of |> Protocol_Message.clean_output - \\The name of the lens associated with a record field\ - fun focus_name rec_name field = rec_name ^ "_" ^ field ^ "_focus" fun focus_type ctxt rec_name field = "(" ^ get_record_type_as_string ctxt rec_name field ^ "," ^ get_field_type_as_string ctxt rec_name field ^ ") focus" @@ -516,13 +930,194 @@ ML\ focus_simps, lens_focus_conversions, code_unfold]} focus_def end - \\Theory transformation adding lens validity lemmas\ - fun focus_autogen_make_field_foci attribs rec_name thy = - let val fields = get_fields rec_name thy in thy - |> fold (make_rec_field_focus_generic @{attributes []} rec_name) fields - |> fold (prove_record_field_focus_components_generic attribs rec_name) fields - |> fold (prove_record_field_focus_code_equations_generic rec_name) fields - end + fun make_focus_component_props + (lens_artifact : autolens_lens_artifact) focus ctxt = + let + val {field, lens, ...} = lens_artifact + val lens_view = + check_application ctxt \<^const_name>\lens_view\ [lens] + val focus_view = + check_application ctxt \<^const_name>\focus_view\ [focus] + val focus_modify = + check_application ctxt \<^const_name>\focus_modify\ [focus] + val focus_update = + check_application ctxt \<^const_name>\focus_update\ [focus] + val selector = + specialize_term_type ctxt (fastype_of lens_view) + (#selector field) + val updater = + specialize_term_type ctxt (fastype_of focus_modify) + (#updater field) + val (record_type, field_type) = + Term.dest_funT (fastype_of selector) + val ([x_name], ctxt') = Variable.variant_fixes ["x"] ctxt + val x = Free (x_name, record_type) + val view_rhs = + check_application ctxt' \<^const_name>\Some\ + [selector $ x] + val update_rhs = + Abs ("x", field_type, + updater $ Abs ("_", field_type, Bound 1)) + in + ([check_equality_prop ctxt' (focus_view $ x) view_rhs, + check_equality_prop ctxt' focus_modify updater, + check_equality_prop ctxt' focus_update update_rhs], + selector, updater, ctxt') + end + + fun prove_focus_component lthy ctxt' prop rules = + prove_autogen_prop_with lthy ctxt' [] prop + (fn {context, ...} => + asm_full_simp_tac + (put_simpset HOL_basic_ss context addsimps rules) 1) + + fun make_focus_code_prop focus selector updater ctxt = + let + val rep_focus = + check_application ctxt \<^const_name>\Rep_focus\ [focus] + val (record_type, field_type) = + Term.dest_funT (fastype_of selector) + val view = + Abs ("s", record_type, + Const (\<^const_name>\Some\, dummyT) $ + (selector $ Bound 0)) + val update = + Abs ("y", field_type, + updater $ Abs ("_", field_type, Bound 1)) + val rhs = + check_application ctxt \<^const_name>\make_focus_raw\ + [view, update] + in + check_equality_prop ctxt rep_focus rhs + end + + fun define_focus_from + (lens_artifact : autolens_lens_artifact) lthy = + let + val {field, lens, ...} = lens_artifact + val rhs = + check_application lthy \<^const_name>\lens_to_focus\ + [lens] + val ((focus, (_, focus_def)), lthy') = + define_typed_constant (#focus_name field) rhs lthy + in + ({lens_artifact = lens_artifact, + focus = focus, + focus_def = focus_def} + : autolens_focus_definition_artifact, + lthy') + end + + fun prove_focus_components_from attribs + (artifact : autolens_focus_definition_artifact) lthy = + let + val {lens_artifact, focus, focus_def} = artifact + val {field, lens_components, lens_valid, ...} = lens_artifact + val (props, selector, updater, component_ctxt) = + make_focus_component_props lens_artifact focus lthy + val generic_components = + Proof_Context.get_thms lthy "lens_to_focus_components" + val component_rules = + focus_def :: lens_valid :: + (generic_components @ lens_components @ + [Proof_Context.get_thm lthy "comp_apply"]) + val focus_components = + map (fn prop => + prove_focus_component lthy component_ctxt + prop component_rules) props + val (_, lthy') = + Local_Theory.note + ((Binding.name (#focus_name field ^ "_view_update_modify"), + attribs), + focus_components) lthy + in + ({lens_artifact = lens_artifact, + focus = focus, + focus_def = focus_def, + focus_components = focus_components} + : autolens_focus_components_artifact, + lthy') + end + + fun prove_focus_code_from + (artifact : autolens_focus_components_artifact) lthy = + let + val {lens_artifact, focus, focus_def, focus_components} = + artifact + val {field, lens_components, lens_valid, ...} = lens_artifact + val (_, selector, updater, _) = + make_focus_component_props lens_artifact focus lthy + val code_prop = + make_focus_code_prop focus selector updater lthy + val code_rules = + [focus_def, lens_valid, + Proof_Context.get_thm lthy "lens_to_focus_raw_def", + Proof_Context.get_thm lthy "lens_to_focus.rep_eq"] + @ lens_components + val focus_code = + Goal.prove lthy [] [] code_prop + (fn {context, ...} => + asm_full_simp_tac + (put_simpset HOL_basic_ss context + addsimps code_rules) 1) + val (_, lthy') = + Local_Theory.note + ((Binding.name (#focus_name field ^ "_code"), + @{attributes [code]}), + [focus_code]) lthy + val (_, lthy'') = + Local_Theory.note + ((Binding.empty, + @{attributes [THEN HOL.meta_eq_to_obj_eq, symmetric, + focus_simps, lens_focus_conversions, + code_unfold]}), + [focus_def]) lthy' + in + ({field = field, + focus = focus, + focus_def = focus_def, + focus_components = focus_components, + focus_code = focus_code} + : autolens_focus_artifact, + lthy'') + end + + fun focus_autogen_defs_from + (_ : autolens_record_descriptor) lens_artifacts lthy = + fold_map define_focus_from lens_artifacts lthy + + fun focus_autogen_components_from attribs + (_ : autolens_record_descriptor) focus_definitions lthy = + fold_map (prove_focus_components_from attribs) + focus_definitions lthy + + fun focus_autogen_code_from + (_ : autolens_record_descriptor) focus_components lthy = + fold_map prove_focus_code_from focus_components lthy + + fun focus_autogen_make_field_foci_from attribs + (descriptor : autolens_record_descriptor) lens_artifacts lthy = + let + val (focus_definitions, lthy1) = + focus_autogen_defs_from descriptor lens_artifacts lthy + val (focus_components, lthy2) = + focus_autogen_components_from attribs descriptor + focus_definitions lthy1 + in + focus_autogen_code_from descriptor focus_components lthy2 + end + + \\Theory transformation adding record field foci.\ + fun focus_autogen_make_field_foci attribs rec_name lthy = + let + val descriptor = prepare_record_descriptor rec_name lthy + val lens_artifacts = + lookup_lens_artifacts_from descriptor lthy + in + focus_autogen_make_field_foci_from + attribs descriptor lens_artifacts lthy + |> snd + end \ @@ -556,7 +1151,8 @@ subsubsection\Other commonly used identities for lenses\ text\This section autoderives further useful identities about the lenses associated with record fields:\ ML\ - fun prove_update_eqns_for_lens attribs_simp attribs_intro rec_name fields field ctxt = let + fun prove_update_eqns_for_lens_legacy attribs_simp attribs_intro + rec_name fields field ctxt = let fun join' sep lst = fold (fn x => fn y => y ^ sep ^ x) lst "" val join = join' " " val make_rec = "make_" ^ rec_name @@ -591,10 +1187,195 @@ ML\ |> Proof.global_done_proof end + fun make_update_explicit_prop constructor + (fields : autolens_field_descriptor list) + (field : autolens_field_descriptor) ctxt = + let + val ([constructor', updater], imported_ctxt) = + Variable.importT_terms [constructor, #updater field] ctxt + val field_types = Term.binder_types (fastype_of constructor') + val _ = + if length field_types = length fields then () + else error "Constructor arity does not match record fields" + val suggested_names = "f" :: map #base_name fields + val (fixed_names, ctxt') = + Variable.variant_fixes suggested_names imported_ctxt + val field_type = nth field_types (#index field) + val f = + Free (hd fixed_names, field_type --> field_type) + val args = + map2 (fn name => fn T => Free (name, T)) + (tl fixed_names) field_types + val record = list_comb (constructor', args) + val updated_args = + map_index + (fn (index, arg) => + if index = #index field then f $ arg else arg) + args + val lhs = updater $ f $ record + val rhs = list_comb (constructor', updated_args) + in + (HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)), ctxt') + end + + fun make_update_local_goal (field : autolens_field_descriptor) ctxt = + let + val ([selector, updater], imported_ctxt) = + Variable.importT_terms [#selector field, #updater field] ctxt + val (record_type, field_type) = + Term.dest_funT (fastype_of selector) + val (fixed_names, ctxt') = + Variable.variant_fixes ["f", "g", "r"] imported_ctxt + val f = + Free (nth fixed_names 0, + field_type --> field_type) + val g = + Free (nth fixed_names 1, + field_type --> field_type) + val r = Free (nth fixed_names 2, record_type) + val selected = selector $ r + val premise = + HOLogic.mk_Trueprop + (HOLogic.mk_eq (f $ selected, g $ selected)) + val conclusion = + HOLogic.mk_Trueprop + (HOLogic.mk_eq + (updater $ f $ r, updater $ g $ r)) + in + (premise, conclusion, r, ctxt') + end + + fun prove_generated_prop_with ctxt ctxt' asms prop tac = + let + val thm = + Goal.prove_future ctxt' [] asms prop tac + in + Variable.export ctxt' ctxt [thm] |> the_single + end + + fun prove_generated_prop ctxt ctxt' prop rules = + prove_generated_prop_with ctxt ctxt' [] prop + (fn {context, ...} => + asm_full_simp_tac (context addsimps rules) 1) + + fun prove_update_local ctxt ctxt' premise conclusion r + updater_def exhaust rules = + prove_generated_prop_with ctxt ctxt' [premise] conclusion + (fn {context, prems} => + Method.insert_tac context prems 1 THEN + Induct_Tacs.case_tac context (Term.term_name r) [] + (SOME exhaust) 1 THEN + asm_full_simp_tac + (put_simpset HOL_basic_ss context + addsimps (updater_def :: rules @ prems)) 1) + + fun note_update_eqns attribs_simp attribs_intro rec_name + ((field : autolens_field_descriptor), explicit, local_thm) lthy = + let + val base = rec_name ^ "_" ^ #base_name field + val (_, lthy') = + Local_Theory.note + ((Binding.name (base ^ "_update_explicit"), attribs_simp), + [explicit]) lthy + val (_, lthy'') = + Local_Theory.note + ((Binding.name (base ^ "_update_localI"), attribs_intro), + [local_thm]) lthy' + in + lthy'' + end + + fun lens_autogen_prove_update_equations_from + attribs_simp attribs_intro + (descriptor : autolens_record_descriptor) lthy = + let + val {source_name, backend, fields, ...} = + descriptor + in + case backend of + AutoLens_Datatype_Record + {constructor, constructor_simps, exhaust, selector_simps} => + let + fun prove_field field = + let + val (explicit_prop, explicit_ctxt) = + make_update_explicit_prop constructor fields field + lthy + val (local_premise, local_conclusion, local_record, + local_ctxt) = + make_update_local_goal field lthy + val updater_def = + (case #updater_def field of + SOME thm => thm + | NONE => + error ("No definition theorem for updater " + ^ quote (#updater_name field))) + val explicit = + prove_generated_prop lthy explicit_ctxt + explicit_prop (updater_def :: constructor_simps) + val local_thm = + prove_update_local lthy local_ctxt + local_premise local_conclusion local_record + updater_def exhaust + (constructor_simps @ selector_simps) + in + {field = field, + update_explicit = explicit, + update_local = local_thm} + : autolens_update_artifact + end + val artifacts = map prove_field fields + val _ = + Thm.consolidate + (maps + (fn ({update_explicit, update_local, ...} + : autolens_update_artifact) => + [update_explicit, update_local]) + artifacts) + fun note + ({field, update_explicit, update_local} + : autolens_update_artifact) = + note_update_eqns attribs_simp attribs_intro source_name + (field, update_explicit, update_local) + in + (artifacts, fold note artifacts lthy) + end + | AutoLens_HOL_Record => + let + val field_names = map #base_name fields + fun prove_legacy + ((field : autolens_field_descriptor), field_name) + current_lthy = + let + val lthy' = + prove_update_eqns_for_lens_legacy + attribs_simp attribs_intro source_name + field_names field_name current_lthy + val base = source_name ^ "_" ^ field_name + in + ({field = field, + update_explicit = + Proof_Context.get_thm lthy' + (base ^ "_update_explicit"), + update_local = + Proof_Context.get_thm lthy' + (base ^ "_update_localI")} + : autolens_update_artifact, + lthy') + end + in + fold_map prove_legacy (fields ~~ field_names) lthy + end + end + \\Theory transformation proving update equations for lenses of a record\ fun lens_autogen_prove_update_equations attribs_simp attribs_intro rec_name thy = - let val fields = get_fields rec_name thy in - thy |> (fold (prove_update_eqns_for_lens attribs_simp attribs_intro rec_name fields) fields) + let + val descriptor = prepare_record_descriptor rec_name thy + in + lens_autogen_prove_update_equations_from + attribs_simp attribs_intro descriptor thy + |> snd end \ diff --git a/Shallow_Micro_Rust/Micro_Rust_Shallow_Embedding.thy b/Shallow_Micro_Rust/Micro_Rust_Shallow_Embedding.thy index 9af871ef..060cf2e8 100644 --- a/Shallow_Micro_Rust/Micro_Rust_Shallow_Embedding.thy +++ b/Shallow_Micro_Rust/Micro_Rust_Shallow_Embedding.thy @@ -98,13 +98,15 @@ ML\ (grammatical, so no bespoke grammar production is emitted) and the lens has type \_ lens\ (so the forced \field\ kind validates against the term's type).\ - fun register_lens_with_micro_rust rec_name overrides field lthy = - let val name = lens_name rec_name field + fun register_lens_with_micro_rust_from overrides + (field : autolens_field_descriptor) lthy = + let val name = #lens_name field + val field_name = #base_name field val full_name = Local_Theory.full_name lthy (Binding.name name) val (rust_name, rust_pos) = - case AList.lookup (op =) overrides field of + case AList.lookup (op =) overrides field_name of SOME name_and_pos => name_and_pos - | NONE => (field, Position.thread_data ()) + | NONE => (field_name, Position.thread_data ()) in Micro_Rust_Notation_Cmd.do_register (SOME Micro_Rust_Names.NField) (full_name, (rust_name, rust_pos)) lthy @@ -121,9 +123,14 @@ ML\ ^ " has fields: " ^ commas_quote fields) end - fun register_lenses_with_micro_rust rec_name overrides thy = - let val fields = get_fields rec_name thy in - fold (register_lens_with_micro_rust rec_name overrides) fields thy + fun register_lenses_with_micro_rust_from + (descriptor : autolens_record_descriptor) overrides lthy = + fold (register_lens_with_micro_rust_from overrides) + (#fields descriptor) lthy + + fun register_lenses_with_micro_rust rec_name overrides lthy = + let val descriptor = prepare_record_descriptor rec_name lthy in + register_lenses_with_micro_rust_from descriptor overrides lthy end \\Pretty-print, as a bullet list, the definitions and theorems @@ -157,27 +164,44 @@ ML\ end fun make_lenses ((with_fields, rec_name), overrides) _ lthy = - let val _ = + let + val _ = if with_fields orelse null overrides then () else error "micro_rust_record: a uRust-name mapping cannot be combined \ \with [no_fields], which suppresses field registration" - val fields = get_fields rec_name lthy + val descriptor = prepare_record_descriptor rec_name lthy + val fields = map #base_name (#fields descriptor) val _ = check_override_fields rec_name fields overrides val _ = summarise_micro_rust_record rec_name fields overrides with_fields + val (lens_definitions, lthy1) = + lens_autogen_defs_from descriptor lthy + val (lens_components, lthy2) = + lens_autogen_defining_equations_from + @{attributes [micro_rust_record_simps, focus_simps]} + descriptor lens_definitions lthy1 + val (lens_artifacts, lthy3) = + lens_autogen_prove_lens_validity_from + @{attributes [micro_rust_record_intros, focus_intros, + micro_rust_record_simps, focus_simps]} + descriptor lens_components lthy2 + val (_, lthy4) = + lens_autogen_prove_update_equations_from + @{attributes [micro_rust_record_simps, focus_simps]} + @{attributes [micro_rust_record_intros, focus_intros]} + descriptor lthy3 + val lthy5 = + focus_autogen_make_field_foci_from + @{attributes [focus_components]} + descriptor lens_artifacts lthy4 + |> snd + val lthy6 = + if with_fields then + register_lenses_with_micro_rust_from + descriptor overrides lthy5 + else + lthy5 in - lthy - |> lens_autogen_defs rec_name - |> lens_autogen_defining_equations @{attributes [micro_rust_record_simps, focus_simps]} rec_name - |> lens_autogen_prove_lens_validity @{attributes [micro_rust_record_intros, focus_intros, - micro_rust_record_simps, focus_simps]} rec_name - |> lens_autogen_prove_update_equations @{attributes [micro_rust_record_simps, focus_simps]} - @{attributes [micro_rust_record_intros, focus_intros]} rec_name - |> focus_autogen_make_field_foci @{attributes [focus_components]} rec_name - |> (if with_fields then - register_lenses_with_micro_rust rec_name overrides - else - I) - |> instantiate_localizable_class rec_name + instantiate_localizable_class rec_name lthy6 end \\Parse an optional \<^verbatim>\(hol_field = "urust_name", \)\ mapping after the diff --git a/Shallow_Micro_Rust/Micro_Rust_Shallow_Embedding_Tests.thy b/Shallow_Micro_Rust/Micro_Rust_Shallow_Embedding_Tests.thy index 9eaeefc7..e04388ac 100644 --- a/Shallow_Micro_Rust/Micro_Rust_Shallow_Embedding_Tests.thy +++ b/Shallow_Micro_Rust/Micro_Rust_Shallow_Embedding_Tests.thy @@ -1735,6 +1735,168 @@ datatype_record testrec2 = field4 :: \bool option\ micro_rust_record testrec2 +datatype_record ('a, 'b) record_autogen_poly = + record_autogen_poly_value :: 'a + record_autogen_poly_flag :: bool + record_autogen_poly_payload :: \'b option\ +micro_rust_record record_autogen_poly + +datatype_record record_autogen_no_fields = + record_autogen_no_fields_value :: nat +micro_rust_record [no_fields] record_autogen_no_fields + +ML_val\ + local + val ctxt = \<^context> + val thy = Proof_Context.theory_of ctxt + + fun assert message condition = + if condition then () + else error ("record autogen compatibility: " ^ message) + + fun theorem name = Proof_Context.get_thm ctxt name + fun theorems name = Proof_Context.get_thms ctxt name + + fun schematic_prop prop = + let + val params = Term.strip_all_vars prop + val body = Term.strip_all_body prop + val frees = map Free params + in + Term.subst_bounds (rev frees, body) + |> Logic.varify_global + end + + fun assert_prop name expected = + assert (quote name ^ " proposition changed") + (Thm.prop_of (theorem name) aconv schematic_prop expected) + + fun same_props [] [] = true + | same_props (theorem :: theorems) (prop :: props) = + Thm.prop_of theorem aconv prop andalso same_props theorems props + | same_props _ _ = false + + fun assert_const_type label name expected = + assert (label ^ " type changed") + (Sign.typ_equiv thy + (Sign.the_const_type thy name, Logic.varifyT_global expected)) + + fun assert_localizable label T = + assert (label ^ " lost its localizable instance") + (Sign.of_sort thy (T, \<^sort>\localizable\)) + + fun named_member collection name = + Named_Theorems.member ctxt collection (theorem name) + + fun entry_targets name + ({hol_term, ...} : Micro_Rust_Names.entry) = + (case hol_term of + Const (actual, _) => actual = name + | _ => false) + + val lens_components = + theorems "testrec_field1_lens_view_update_modify" + val focus_components = + theorems "testrec_field1_focus_view_update_modify" + val field1_entries = + Micro_Rust_Names.lookups ctxt Micro_Rust_Names.NField "field1" + val no_fields_entries = + Micro_Rust_Names.lookups ctxt Micro_Rust_Names.NField + "record_autogen_no_fields_value" + + val _ = + assert_const_type "ordinary lens" + \<^const_name>\testrec_field1_lens\ + \<^typ>\(testrec, integer) lens\ + val _ = + assert_const_type "ordinary focus" + \<^const_name>\testrec_field1_focus\ + \<^typ>\(testrec, integer) focus\ + val _ = + assert_const_type "polymorphic value lens" + \<^const_name>\record_autogen_poly_record_autogen_poly_value_lens\ + \<^typ>\(('a, 'b) record_autogen_poly, 'a) lens\ + val _ = + assert_const_type "polymorphic Boolean focus" + \<^const_name>\record_autogen_poly_record_autogen_poly_flag_focus\ + \<^typ>\(('a, 'b) record_autogen_poly, bool) focus\ + val _ = + assert_const_type "polymorphic option lens" + \<^const_name>\record_autogen_poly_record_autogen_poly_payload_lens\ + \<^typ>\(('a, 'b) record_autogen_poly, 'b option) lens\ + val _ = + assert_const_type "no-fields lens" + \<^const_name>\record_autogen_no_fields_record_autogen_no_fields_value_lens\ + \<^typ>\(record_autogen_no_fields, nat) lens\ + + val _ = + assert_prop "testrec_field1_update_explicit" + \<^prop>\\f field1 field2. + update_field1 f (make_testrec field1 field2) = + make_testrec (f field1) field2\ + val _ = + assert_prop "testrec_field1_update_localI" + \<^prop>\\f g r. + f (field1 r) = g (field1 r) \ + update_field1 f r = update_field1 g r\ + + val _ = + assert "lens component grouping or order changed" + (same_props lens_components + [\<^prop>\lens_view testrec_field1_lens = field1\, + \<^prop>\lens_modify testrec_field1_lens = update_field1\, + \<^prop>\lens_update testrec_field1_lens = + (\x. update_field1 (\_. x))\]) + val _ = + assert "focus component theorem grouping changed" + (length focus_components = 3) + + val _ = + assert "lens components left micro_rust_record_simps" + (forall + (Named_Theorems.member ctxt + \<^named_theorems>\micro_rust_record_simps\) + lens_components) + val _ = + assert "lens validity left micro_rust_record_intros" + (named_member \<^named_theorems>\micro_rust_record_intros\ + "testrec_field1_lens_valid") + val _ = + assert "explicit update left micro_rust_record_simps" + (named_member \<^named_theorems>\micro_rust_record_simps\ + "testrec_field1_update_explicit") + val _ = + assert "local update left micro_rust_record_intros" + (named_member \<^named_theorems>\micro_rust_record_intros\ + "testrec_field1_update_localI") + val _ = + assert "focus components left focus_components" + (forall + (Named_Theorems.member ctxt + \<^named_theorems>\focus_components\) + focus_components) + + val _ = + assert "ordinary field registration changed" + (length field1_entries = 1 andalso + entry_targets \<^const_name>\testrec_field1_lens\ + (hd field1_entries)) + val _ = + assert "[no_fields] registered its field" + (null no_fields_entries) + + val _ = + assert_localizable "ordinary record" \<^typ>\testrec\ + val _ = + assert_localizable "polymorphic record" + \<^typ>\('a, 'b) record_autogen_poly\ + val _ = + assert_localizable "no-fields record" + \<^typ>\record_autogen_no_fields\ + in + end +\ + subsubsection\Simple Field Access\ context From 445a2a7666c1c6fbb99043d0d6fcbb03bbf0e0f4 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Sat, 26 Sep 2026 05:42:29 +0100 Subject: [PATCH 29/46] Fine-Grained Timing: Report exceptions from profiled pulls A profiled method can raise while its sequence is being pulled. The exception previously escaped before invocation timing was accumulated or its PIDE snapshot was emitted, so samples gathered before the failure were lost. Capture the pull result, add its elapsed time to the invocation total, emit a failed snapshot for an exception, and re-raise the original exception. Successful pulls retain their existing result and backtracking behavior. Signed-off-by: Hanno Becker --- .../test/Fine_Grained_Timing_Test.thy | 30 +++++++++++++++++ Fine_Grained_Timing/time.ML | 33 ++++++++++++------- 2 files changed, 51 insertions(+), 12 deletions(-) diff --git a/Fine_Grained_Timing/test/Fine_Grained_Timing_Test.thy b/Fine_Grained_Timing/test/Fine_Grained_Timing_Test.thy index 75ea411c..f6b7946b 100644 --- a/Fine_Grained_Timing/test/Fine_Grained_Timing_Test.thy +++ b/Fine_Grained_Timing/test/Fine_Grained_Timing_Test.thy @@ -257,6 +257,36 @@ ML \ end | _ => error "Timing-only pulls did not emit repeated snapshots") + (* Exceptions raised while pulling a profiled sequence must still publish + the samples gathered before the exception, then escape unchanged. *) + val raising_reports = + Synchronized.var "profile exception observer" ([]: Properties.T list) + val raising_context = + profile_context + |> Config.put Fine_Grained_Timing.timing_threshold_us 0 + |> Fine_Grained_Timing.set_report_observer + (fn _ => fn properties => fn _ => + Synchronized.change raising_reports (cons properties)) + val raising_result = + Exn.capture (fn () => + Fine_Grained_Timing.profile_seq (K true) "raising" raising_context + (fn ctxt => + Seq.make (fn _ => + (Fine_Grained_Timing.time_and_report + ctxt "before_raise" true (fn () => ()); + error "profile test exception"))) + |> Seq.pull) () + val _ = + (case raising_result of + Exn.Exn _ => () + | Exn.Res _ => error "Profiling swallowed a pull exception") + val _ = + (case Synchronized.value raising_reports of + properties :: _ => + if Properties.get properties "success" = SOME "false" then () + else error "An exception report was not marked as failed" + | [] => error "Profiling did not report a pull exception") + (* `profile_method` distinguishes a failing method from one that yields no result at all, so the outcome predicate must see `Seq.Error`. *) val error_result = diff --git a/Fine_Grained_Timing/time.ML b/Fine_Grained_Timing/time.ML index 34255655..6682b298 100644 --- a/Fine_Grained_Timing/time.ML +++ b/Fine_Grained_Timing/time.ML @@ -640,22 +640,31 @@ struct fun wrap succeeded reported make = Seq.make (fn _ => let - val (pull_timing, output) = - time_it (fn _ => Seq.pull (make ())) () + val start = Timing.start () + val pulled = Exn.capture (fn _ => Seq.pull (make ())) () + val pull_timing = Timing.result start val _ = Synchronized.change invocation_timing (add_timing pull_timing) - val succeeded' = - succeeded orelse - (case output of - NONE => false - | SOME (element, _) => element_success element) - val reported' = report succeeded' reported in - Option.map - (fn (element, tail) => - (element, wrap succeeded' reported' (fn _ => tail))) - output + case pulled of + Exn.Exn exn => + (report false reported; + Exn.reraise exn) + | Exn.Res output => + let + val succeeded' = + succeeded orelse + (case output of + NONE => false + | SOME (element, _) => element_success element) + val reported' = report succeeded' reported + in + Option.map + (fn (element, tail) => + (element, wrap succeeded' reported' (fn _ => tail))) + output + end end) in wrap false (~1, NONE, NONE) (fn _ => make_sequence ctxt') end From 4e3cd7b56b368708546c0ddade9af2233d75f1e8 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Sat, 26 Sep 2026 05:42:40 +0100 Subject: [PATCH 30/46] AutoLocality: Unfold helpers after ambiguous lookup A helper used by a locality lemma can have registrations at more than one record position. If those registrations have different effects, certificate selection raises instead of reaching the definition-unfolding fallback. Treat only `Locality_Registry_Ambiguity` as an uncovered helper and let the normal discharge unfold it. Interrupts and unrelated exceptions still escape, and unambiguous registrations continue to use their certificates. Signed-off-by: Hanno Becker --- Autogen/AutoLocality.thy | 11 ++++++----- .../AutoLocality_Tests/AutoLocality_Test_Contexts.thy | 5 +++++ 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/Autogen/AutoLocality.thy b/Autogen/AutoLocality.thy index 72e35950..03ee10bb 100644 --- a/Autogen/AutoLocality.thy +++ b/Autogen/AutoLocality.thy @@ -3044,11 +3044,12 @@ ML\ val applications = locality_body_helper_applications ctxt cname helpers fun matching_entries head args = - [Locality_Operation, Locality_Attribute] - |> map_filter (fn kind => - select_locality_entry_kind_with locality_no_count - ctxt rec_name kind head args - |> Option.map #2) + ([Locality_Operation, Locality_Attribute] + |> map_filter (fn kind => + select_locality_entry_kind_with locality_no_count + ctxt rec_name kind head args + |> Option.map #2)) + handle Locality_Registry_Ambiguity _ => [] fun entry_certificates (entry : locality_entry) = #core_thms entry @ #disjoint_thms entry fun analyse helper = diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Contexts.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Contexts.thy index 73263717..d8f76ab0 100644 --- a/Autogen/AutoLocality_Tests/AutoLocality_Test_Contexts.thy +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Contexts.thy @@ -269,6 +269,11 @@ definition pair_attr :: \ctx \ ctx \ bool\ locality_lemma for ctx: \pair_attr\ [0] footprint [xa] . locality_lemma for ctx: \pair_attr\ [1] footprint [xb] . +definition wrapped_pair_attr :: \ctx \ ctx \ bool\ where + \wrapped_pair_attr L R \ pair_attr L R\ + +locality_lemma for ctx: \wrapped_pair_attr\ footprint [xa, xb] . + lemma \pair_attr (set_c n L) R = pair_attr L R\ by simp From 14fb9cfd8dd47fad49908fff254d352a4db073c2 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Sat, 26 Sep 2026 06:31:47 +0100 Subject: [PATCH 31/46] Fine-Grained Timing: Preserve raised invocation outcomes An invocation can yield, then raise while its caller backtracks. With equal sample counts, the panel kept the earlier success and hid the later failure and its longer timing. Record raised pulls in PIDE reports and carry that outcome through panel decoding and snapshot selection. Prefer raised over success for equal samples, while retaining success-wins behavior for ordinary failed-then-successful reports. Signed-off-by: Hanno Becker --- .../test/Fine_Grained_Timing_Test.thy | 4 ++- Fine_Grained_Timing/time.ML | 24 ++++++++++------- .../src/FineGrainedTiming.scala | 16 ++++++++---- .../test/FineGrainedTimingTest.scala | 26 +++++++++++++++++-- 4 files changed, 53 insertions(+), 17 deletions(-) diff --git a/Fine_Grained_Timing/test/Fine_Grained_Timing_Test.thy b/Fine_Grained_Timing/test/Fine_Grained_Timing_Test.thy index f6b7946b..78c8085d 100644 --- a/Fine_Grained_Timing/test/Fine_Grained_Timing_Test.thy +++ b/Fine_Grained_Timing/test/Fine_Grained_Timing_Test.thy @@ -283,7 +283,9 @@ ML \ val _ = (case Synchronized.value raising_reports of properties :: _ => - if Properties.get properties "success" = SOME "false" then () + if Properties.get properties "success" = SOME "false" andalso + Properties.get properties "raised" = SOME "true" + then () else error "An exception report was not marked as failed" | [] => error "Profiling did not report a pull exception") diff --git a/Fine_Grained_Timing/time.ML b/Fine_Grained_Timing/time.ML index 6682b298..4c9d26cf 100644 --- a/Fine_Grained_Timing/time.ML +++ b/Fine_Grained_Timing/time.ML @@ -395,7 +395,7 @@ struct fun emit_pide_report ctxt ({id, invocation_name, position, statistics, timing}: pide_invocation) - success = + success raised = let val total = Synchronized.value timing val properties = [ @@ -403,6 +403,7 @@ struct ("invocation", Value.print_int id), ("method", invocation_name), ("success", Bool.toString success), + ("raised", Bool.toString raised), ("elapsed_us", encode_time (#elapsed total)), ("cpu_us", encode_time (#cpu total)), ("gc_us", encode_time (#gc total)) @@ -620,8 +621,9 @@ struct (Time.toMicroseconds elapsed, Time.toMicroseconds cpu, Time.toMicroseconds gc) - fun report succeeded - (reported_samples, reported_success, reported_timing) = + fun report succeeded raised + (reported_samples, reported_success, reported_raised, + reported_timing) = let val samples = Fine_Grained_Timing_Accumulator.total_samples @@ -631,11 +633,14 @@ struct in if samples = reported_samples andalso reported_success = SOME succeeded andalso + reported_raised = SOME raised andalso reported_timing = SOME current_timing - then (reported_samples, reported_success, reported_timing) + then + (reported_samples, reported_success, reported_raised, + reported_timing) else - (emit_pide_report ctxt' invocation succeeded; - (samples, SOME succeeded, SOME current_timing)) + (emit_pide_report ctxt' invocation succeeded raised; + (samples, SOME succeeded, SOME raised, SOME current_timing)) end fun wrap succeeded reported make = Seq.make (fn _ => @@ -649,7 +654,7 @@ struct in case pulled of Exn.Exn exn => - (report false reported; + (report false true reported; Exn.reraise exn) | Exn.Res output => let @@ -658,7 +663,7 @@ struct (case output of NONE => false | SOME (element, _) => element_success element) - val reported' = report succeeded' reported + val reported' = report succeeded' false reported in Option.map (fn (element, tail) => @@ -666,7 +671,8 @@ struct output end end) - in wrap false (~1, NONE, NONE) (fn _ => make_sequence ctxt') end + in wrap false (~1, NONE, NONE, NONE) + (fn _ => make_sequence ctxt') end fun profile_tactic invocation_name ctxt make_tactic state = profile_seq (K true) invocation_name ctxt diff --git a/Fine_Grained_Timing_Panel/src/FineGrainedTiming.scala b/Fine_Grained_Timing_Panel/src/FineGrainedTiming.scala index 37f9e7e8..10514cb4 100644 --- a/Fine_Grained_Timing_Panel/src/FineGrainedTiming.scala +++ b/Fine_Grained_Timing_Panel/src/FineGrainedTiming.scala @@ -70,7 +70,8 @@ object FineGrainedTiming { method: String, success: Boolean, timing: Option[Timing], - samples: Vector[Sample] + samples: Vector[Sample], + raised: Boolean = false ) { /* Nested samples may overlap, so their aggregate times cannot be added to obtain the invocation's wall time. New schema 2 producers carry an @@ -108,16 +109,18 @@ object FineGrainedTiming { private def supersedes(candidate: Invocation, existing: Invocation): Boolean = { val candidateSamples = sampleCount(candidate) val existingSamples = sampleCount(existing) + def outcomeRank(invocation: Invocation): Int = + if (invocation.raised) 2 else if (invocation.success) 1 else 0 candidateSamples > existingSamples || (candidateSamples == existingSamples && - (candidate.success && !existing.success || - candidate.success == existing.success && + (outcomeRank(candidate) > outcomeRank(existing) || + outcomeRank(candidate) == outcomeRank(existing) && laterTiming(candidate, existing))) } /* A profile re-reports as its caller pulls more results. Every report of one invocation carries the same id and a complete snapshot. Keep the snapshot - with the most samples, then the latest outcome and outer timing. */ + with the most samples, then the terminal outcome and outer timing. */ def latestPerInvocation( invocations: Iterable[Invocation] ): Vector[Invocation] = @@ -162,7 +165,10 @@ object FineGrainedTiming { method = method, success = success, timing = timing, - samples = samples + samples = samples, + raised = Properties.get(properties, "raised") + .flatMap(Value.Boolean.unapply) + .getOrElse(false) ) case _ => None } diff --git a/Fine_Grained_Timing_Panel/test/FineGrainedTimingTest.scala b/Fine_Grained_Timing_Panel/test/FineGrainedTimingTest.scala index 89a892b6..aefe53ef 100644 --- a/Fine_Grained_Timing_Panel/test/FineGrainedTimingTest.scala +++ b/Fine_Grained_Timing_Panel/test/FineGrainedTimingTest.scala @@ -45,7 +45,8 @@ object FineGrainedTimingTest { version: Int, body: XML.Body, invocationTiming: Option[FineGrainedTiming.Timing] = None, - success: Boolean = true + success: Boolean = true, + raised: Boolean = false ): XML.Tree = XML.Elem( Markup( @@ -54,7 +55,8 @@ object FineGrainedTimingTest { "version" -> Value.Int(version), "invocation" -> Value.Long(17L), "method" -> "example_method", - "success" -> Value.Boolean(success) + "success" -> Value.Boolean(success), + "raised" -> Value.Boolean(raised) ) ++ (if (version == FineGrainedTiming.LegacySchemaVersion) List( @@ -173,6 +175,16 @@ object FineGrainedTimingTest { )).get requireThat(legacySchemaTwo.totalTiming.isEmpty, "schema 2 reports without an outer timing should remain decodable") + + val raised = FineGrainedTiming.decode(report( + FineGrainedTiming.SchemaVersion, + List(entry("sample", success = false, 1L, 60L, List(bucket(5, 1)))), + invocationTiming = Some(outer), + success = false, + raised = true + )).get + requireThat(raised.raised && !raised.success, + "raised schema 2 reports should preserve their terminal outcome") } private def testRepeatedSnapshotsKeepTheLatest(): Unit = { @@ -203,6 +215,16 @@ object FineGrainedTimingTest { requireThat(latestOutcome.head.success, "success should supersede failure when sample counts are equal") + val raised = partial.copy( + success = false, + raised = true, + timing = Some(FineGrainedTiming.Timing(90L, 20L, 1L)) + ) + val afterRaise = + FineGrainedTiming.latestPerInvocation(Vector(successful, raised)) + requireThat(afterRaise.head.raised && !afterRaise.head.success, + "a raised snapshot should supersede an earlier successful snapshot") + val earlyTiming = partial.copy(timing = Some(FineGrainedTiming.Timing(10L, 5L, 0L))) val lateTiming = From ffd1925aee2a80f91bd5fe9fc9fd0f872be2a87a Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Sat, 26 Sep 2026 06:32:03 +0100 Subject: [PATCH 32/46] Fine-Grained Timing: Aggregate Calls by invocation timing The Calls view grouped methods by nested sample aggregates, while its invocation rows showed outer timing. Calls without nested samples showed zero count and time, and slow calls could sort below faster calls. Aggregate Calls groups from outer timings. Count only timed invocations, retain timing ranges and histogram buckets, and leave the nested-sample Aggregate view unchanged. Signed-off-by: Hanno Becker --- .../src/FineGrainedTimingDockable.scala | 3 +- .../src/FineGrainedTimingHierarchy.scala | 45 ++++++++++---- .../test/FineGrainedTimingHierarchyTest.scala | 62 +++++++++++++++++-- 3 files changed, 92 insertions(+), 18 deletions(-) diff --git a/Fine_Grained_Timing_Panel/src/FineGrainedTimingDockable.scala b/Fine_Grained_Timing_Panel/src/FineGrainedTimingDockable.scala index 77bd552d..3f7d5410 100644 --- a/Fine_Grained_Timing_Panel/src/FineGrainedTimingDockable.scala +++ b/Fine_Grained_Timing_Panel/src/FineGrainedTimingDockable.scala @@ -968,7 +968,8 @@ extends JPanel(new BorderLayout) with DefaultFocusComponent { Vector( location, invocation.method, - if (invocation.success) "success" else "failure", + if (invocation.raised) "raised" + else if (invocation.success) "success" else "failure", sampleCount.toString, elapsed.getOrElse(""), "", diff --git a/Fine_Grained_Timing_Panel/src/FineGrainedTimingHierarchy.scala b/Fine_Grained_Timing_Panel/src/FineGrainedTimingHierarchy.scala index c4658373..029491b2 100644 --- a/Fine_Grained_Timing_Panel/src/FineGrainedTimingHierarchy.scala +++ b/Fine_Grained_Timing_Panel/src/FineGrainedTimingHierarchy.scala @@ -70,13 +70,8 @@ object FineGrainedTimingHierarchy { Signal(invocation.method, invocation.success) } .foreach { case (signal, indexedInvocations) => - val aggregate = - indexedInvocations.iterator - .flatMap { case (invocation, _) => - invocation.samples.iterator.map(_.aggregate) - } - .reduceOption(_ + _) - .getOrElse(EmptyAggregate) + val aggregate = callAggregate( + indexedInvocations.iterator.map(_._1)) add( signal, CommandData( @@ -153,12 +148,36 @@ object FineGrainedTimingHierarchy { ): Option[FineGrainedTiming.Aggregate] = aggregates.reduceOption(_ + _) - private val EmptyAggregate = + private def callAggregate( + invocations: Iterator[FineGrainedTiming.Invocation] + ): FineGrainedTiming.Aggregate = { + val values = invocations.toVector + val timed = values.flatMap { invocation => + invocation.totalTiming.map(timing => (invocation, timing)) + } + val total = timed.iterator + .map(_._2) + .foldLeft(FineGrainedTiming.Timing(0L, 0L, 0L))(_ + _) + val elapsed = timed.map(_._2.elapsedMicros) + val histogram = timed + .groupBy { case (_, timing) => timingBucket(timing) } + .view + .mapValues(_.size.toLong) + .toMap FineGrainedTiming.Aggregate( - count = 0L, - timing = FineGrainedTiming.Timing(0L, 0L, 0L), - minElapsedMicros = 0L, - maxElapsedMicros = 0L, - histogram = Map.empty + count = timed.size.toLong, + timing = total, + minElapsedMicros = elapsed.minOption.getOrElse(0L), + maxElapsedMicros = elapsed.maxOption.getOrElse(0L), + histogram = histogram ) + } + + private def timingBucket(timing: FineGrainedTiming.Timing): Int = + timingBucket(timing.elapsedMicros) + + private def timingBucket(elapsedMicros: Long): Int = + if (elapsedMicros <= 1L) 0 + else 63 - java.lang.Long.numberOfLeadingZeros(elapsedMicros) + } diff --git a/Fine_Grained_Timing_Panel/test/FineGrainedTimingHierarchyTest.scala b/Fine_Grained_Timing_Panel/test/FineGrainedTimingHierarchyTest.scala index 851a330d..ebac17a5 100644 --- a/Fine_Grained_Timing_Panel/test/FineGrainedTimingHierarchyTest.scala +++ b/Fine_Grained_Timing_Panel/test/FineGrainedTimingHierarchyTest.scala @@ -35,6 +35,22 @@ object FineGrainedTimingHierarchyTest { }.toVector ) + private def untimedInvocation( + id: Long, + method: String, + success: Boolean, + samples: (String, Boolean, FineGrainedTiming.Aggregate)* + ): FineGrainedTiming.Invocation = + FineGrainedTiming.Invocation( + id, + method, + success, + None, + samples.map { case (name, sampleSuccess, sampleAggregate) => + FineGrainedTiming.Sample(name, sampleSuccess, sampleAggregate) + }.toVector + ) + private val commands = Vector( FineGrainedTimingHierarchy.Command( @@ -87,6 +103,26 @@ object FineGrainedTimingHierarchyTest { elapsed = 30L ) ) + ), + FineGrainedTimingHierarchy.Command( + "command-4", + order = 3, + theory = "T4", + proof = Some("p4"), + Vector( + invocation( + 5L, + "slow_profile", + success = true, + elapsed = 1000L + ), + untimedInvocation( + 6L, + "unknown_profile", + success = true, + ("branch", true, aggregate(1L, 4L)) + ) + ) ) ) @@ -103,9 +139,10 @@ object FineGrainedTimingHierarchyTest { val signal = index.signals.head requireThat(signal.signal == FineGrainedTimingHierarchy.Signal("branch", true), s"unexpected signal ${signal.signal}") - requireThat(signal.aggregate.count == 5L, + requireThat(signal.aggregate.count == 6L, s"aggregate count should merge commands: ${signal.aggregate.count}") - requireThat(signal.commands.map(_.command.theory) == Vector("T1", "T2"), + requireThat(signal.commands.map(_.command.theory) == + Vector("T1", "T2", "T4"), s"command order was not retained: ${signal.commands}") } @@ -130,8 +167,25 @@ object FineGrainedTimingHierarchyTest { index.signals.find(_.signal == FineGrainedTimingHierarchy.Signal("empty_profile", true)) .getOrElse(sys.error(s"missing zero-sample call: ${index.signals}")) - requireThat(empty.aggregate.count == 0L && empty.commands.head.invocations.length == 1, - s"zero-sample call was not indexed: $empty") + requireThat( + empty.aggregate.count == 1L && + empty.aggregate.timing.elapsedMicros == 30L && + empty.commands.head.invocations.length == 1, + s"zero-sample call was not aggregated from invocation timing: $empty") + requireThat( + index.signals.head.signal == + FineGrainedTimingHierarchy.Signal("slow_profile", true), + s"Calls groups were not sorted by invocation timing: ${index.signals}") + val unknown = + index.signals.find(_.signal == + FineGrainedTimingHierarchy.Signal("unknown_profile", true)) + .getOrElse(sys.error(s"missing unknown-timing signal: ${index.signals}")) + requireThat( + unknown.aggregate.count == 0L && + unknown.aggregate.timing.elapsedMicros == 0L && + unknown.aggregate.histogram.isEmpty && + unknown.commands.head.invocations.length == 1, + s"unknown timings were included in Calls aggregates: $unknown") val left = FineGrainedTimingHierarchy.build( From f63d8b3af61b4bafedd0ace2d9d1a1ec82ac1bfc Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Mon, 28 Sep 2026 05:57:08 -0500 Subject: [PATCH 33/46] AutoCorrode: Ignore stale component registrations A component file can retain a path from a deleted worktree. The old basename fallback treated it as live, so a new checkout skipped registration and later failed to find the component. Filter component-file entries by directory existence before applying the basename fallback. Exact path matches and registration of existing candidates remain unchanged. Signed-off-by: Hanno Becker --- Makefile | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/Makefile b/Makefile index 5e1c020a..077b338a 100644 --- a/Makefile +++ b/Makefile @@ -34,9 +34,11 @@ define ensure_registered system_comp='$(ISABELLE_SYSTEM_COMPONENTS)'; \ user_comp='$(ISABELLE_USER_COMPONENTS)'; \ component_entries() { \ - for comp in "$$system_comp" "$$user_comp"; do \ - [ ! -f "$$comp" ] || cat "$$comp"; \ - done; \ + for comp in "$$system_comp" "$$user_comp"; do \ + [ ! -f "$$comp" ] || while IFS= read -r entry; do \ + [ -d "$$entry" ] && printf '%s\n' "$$entry"; \ + done < "$$comp"; \ + done; \ }; \ dir=""; \ if [ -n "$$cand" ]; then dir=$$(cd "$$cand" 2>/dev/null && pwd || true); fi; \ From f219688db02aa48ed7d0c20e1793d62cc24136f5 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Mon, 28 Sep 2026 05:57:16 -0500 Subject: [PATCH 34/46] AutoLocality: Decline ambiguous simproc lookups A simplifier callback must decline when registry lookup finds incompatible registrations. Re-raising `Locality_Registry_Ambiguity` from a simproc aborts simp and auto goals even though no safe cancellation was available. Catch that exception in the entry, compatibility, and dispatch wrappers and return `NONE`, while explicit inference and interrupts retain their existing behavior. Add a plain Isabelle record regression for baked helper unfolding. Signed-off-by: Hanno Becker --- Autogen/AutoLocality.thy | 35 ++++++++++++++----- .../AutoLocality_Test_Record_Extension.thy | 13 +++++++ 2 files changed, 39 insertions(+), 9 deletions(-) diff --git a/Autogen/AutoLocality.thy b/Autogen/AutoLocality.thy index 03ee10bb..14fd3f07 100644 --- a/Autogen/AutoLocality.thy +++ b/Autogen/AutoLocality.thy @@ -4267,12 +4267,22 @@ ML\ locality_cancellation_for_entry_with (locality_direct_counter ctxt) rec_name attribute ctxt ctm + fun locality_simproc_decline_ambiguity f = + (case Exn.capture f () of + Exn.Res result => result + | Exn.Exn exn => + if Exn.is_interrupt exn then Exn.reraise exn + else (case exn of + Locality_Registry_Ambiguity _ => NONE + | _ => Exn.reraise exn)) + fun locality_cancellation_simproc_for_entry rec_name attribute ctxt ctm = if not (Config.get ctxt locality_cancel_enabled) then NONE else - locality_with_callback ctxt (fn count => - locality_cancellation_for_entry_with count - rec_name attribute ctxt ctm) + locality_simproc_decline_ambiguity (fn () => + locality_with_callback ctxt (fn count => + locality_cancellation_for_entry_with count + rec_name attribute ctxt ctm)) \\Compatibility entry point used by the ML regression harness. Simprocs installed by declarations close over only their family dispatch key and do not use this @@ -4280,8 +4290,9 @@ ML\ fun locality_cancellation_simproc rec_name attr_name idx ctxt ctm = if not (Config.get ctxt locality_cancel_enabled) then NONE else - locality_with_callback ctxt (fn count => - let + locality_simproc_decline_ambiguity (fn () => + locality_with_callback ctxt (fn count => + let val context = Context.Proof ctxt val parsed_const = try (Syntax.read_term ctxt #> extract_const) attr_name @@ -4330,7 +4341,7 @@ ML\ (locality_specialize_entry_with count ctxt actual entry) ctxt ctm end - end) + end)) fun locality_prove_cancellation_fact ctxt (rec_name0 : string) (operation_pattern : term) (attribute_pattern : term) @@ -4470,8 +4481,9 @@ ML\ fun try_entries [] = NONE | try_entries (entry :: entries) = - (case locality_cancellation_for_entry_with count - (locality_entry_record_name entry) entry ctxt ctm of + (case locality_simproc_decline_ambiguity (fn () => + locality_cancellation_for_entry_with count + (locality_entry_record_name entry) entry ctxt ctm) of NONE => try_entries entries | result => result) @@ -4814,8 +4826,13 @@ ML\ with its own, deliberately broader, test. *) fun baked_const_unfoldable (c, T) = let + val rec_ty_name = + (case rec_ty of + Type (name, _) => name + | _ => rec_name) val mentions_record = - T |> Term.exists_subtype (fn Type (n, _) => n = rec_name | _ => false) + T |> Term.exists_subtype + (fn Type (n, _) => n = rec_ty_name | _ => false) val declaring_theory = try (Name_Space.theory_name {long = true} (Consts.space_of (Proof_Context.consts_of ctxt))) c diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Record_Extension.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Record_Extension.thy index 1721787a..4a2bd10b 100644 --- a/Autogen/AutoLocality_Tests/AutoLocality_Test_Record_Extension.thy +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Record_Extension.thy @@ -28,9 +28,19 @@ definition std_set_c :: \nat \ standard_ext \ stan definition std_has_b :: \standard_ext \ bool\ where \std_has_b R \ std_b R > 0\ +definition std_apply_policy :: + \(standard_ext \ nat) \ standard_ext \ standard_ext\ where + \std_apply_policy policy R \ + std_a_update (\_. policy R) R\ + +definition std_policy :: \standard_ext \ nat\ where + \std_policy R \ std_b R\ + locality_lemma for standard_ext: \std_bump_a\ footprint [std_a] . locality_lemma for standard_ext: \std_set_c\ footprint [std_c] . locality_lemma for standard_ext: \std_has_b\ footprint [std_b] . +locality_lemma for standard_ext: + \std_apply_policy std_policy\ footprint [std_a, std_b] . lemma \std_has_b (std_bump_a (std_set_c n R)) = std_has_b R\ by simp @@ -44,6 +54,9 @@ lemma \std_c (std_bump_a R) = std_c R\ lemma \std_c (std_a_update f R) = std_c R\ by simp +lemma \std_c (std_apply_policy std_policy R) = std_c R\ + by simp + ML\ val ctxt = \<^context> val rec_name = "AutoLocality_Test_Record_Extension.standard_ext" From 069fa43c3aedee31c1bc9fb67f819c21167f2658 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Fri, 25 Sep 2026 08:50:15 +0000 Subject: [PATCH 35/46] Misc: Add `quiet_context` to open a named context silently `context NAME begin` always prints the target it opens. `Toplevel.begin_main_target` calls `Local_Theory.pretty` every time, and no option turns this off. For a locale, `Locale.pretty_locale` runs `Locale.init` again and re-activates every locale element just to build the text. For a large locale that a development opens many times, building this printout can cost as much as opening the locale, and the text is rarely read. Add `quiet_context` as `Misc/Quiet_Context.thy`. `quiet_context NAME begin` and `quiet_context NAME opening BUNDLES begin` accept exactly the named forms of `context`. They build the local theory with the same call, `Target_Context.context_begin_named_cmd`, and enter it through `Toplevel.generic_theory`. This leaves the same toplevel node and presentation context and skips only the print. `end` closes the block as before. The keyword has kind `thy_decl_block`, the kind of `context`. The anonymous form `context fixes ... begin` is not covered. It goes through `begin_nested_target`, which never prints. Signed-off-by: Hanno Becker --- Misc/Misc.thy | 1 + Misc/Quiet_Context.thy | 51 ++++++++++++++++++++++++++++++++++++++++++ Misc/ROOT | 1 + 3 files changed, 53 insertions(+) create mode 100644 Misc/Quiet_Context.thy diff --git a/Misc/Misc.thy b/Misc/Misc.thy index 1e185b0b..0e6493f5 100644 --- a/Misc/Misc.thy +++ b/Misc/Misc.thy @@ -10,6 +10,7 @@ theory Misc Debug_Logging ListAdditional MultisetAdditional + Quiet_Context Remove_Enum_Discriminate_Elims Result SetAdditional diff --git a/Misc/Quiet_Context.thy b/Misc/Quiet_Context.thy new file mode 100644 index 00000000..e295d369 --- /dev/null +++ b/Misc/Quiet_Context.thy @@ -0,0 +1,51 @@ +(* Copyright Amazon.com, Inc. or its affiliates. All Rights Reserved. + SPDX-License-Identifier: MIT *) + +(*<*) +theory Quiet_Context + imports Pure + keywords "quiet_context" :: thy_decl_block +begin +(*>*) + +section\Opening a named context without printing it\ + +text\\<^theory_text>\quiet_context\ is logically the same command as +\<^theory_text>\context\. It differs only in that it prints nothing. + +\<^theory_text>\quiet_context name begin\ and +\<^theory_text>\quiet_context name opening bundles begin\ accept exactly the named forms of +\<^theory_text>\context\. They build the local theory with the same function that +\<^theory_text>\context\ uses, \<^ML>\Target_Context.context_begin_named_cmd\, on the same +arguments. The resulting context is therefore identical: the same target, fixes, assumptions, +facts, constants, syntax and bundle declarations. Everything declared inside the block goes to the +target exactly as it would under \<^theory_text>\context\. The block is closed by +\<^theory_text>\end\, and \<^theory_text>\end\ behaves the same way. Replacing +\<^theory_text>\context\ by \<^theory_text>\quiet_context\, or back, changes no fact and +no proof obligation. + +The one difference is output. \<^theory_text>\context name begin\ always prints the target it +opens, and Isabelle offers no option to turn this off. For a locale, building that text initializes +the locale a second time and activates all of its elements again. This can cost as much as opening +the locale itself, and the text is rarely read. \<^theory_text>\quiet_context\ skips it. Use +\<^theory_text>\print_locale\ or \<^theory_text>\print_context\ when the text is +needed. + +The anonymous form \<^theory_text>\context fixes \ begin\ is not supported. It prints +nothing already, so there is nothing to skip.\ + +ML\ +val _ = + Outer_Syntax.command \<^command_keyword>\quiet_context\ + "begin named local theory context without printing the target" + ((Parse.name_position -- Scan.optional Parse_Spec.opening []) --| Parse.begin + >> (fn (name, incls) => + Toplevel.generic_theory + (fn Context.Theory thy => + Context.Proof (Target_Context.context_begin_named_cmd incls name thy) + | Context.Proof _ => error "quiet_context: not at theory level"))); +\ + +(*<*) +end +(*>*) diff --git a/Misc/ROOT b/Misc/ROOT index 3af4fa39..94c07a52 100644 --- a/Misc/ROOT +++ b/Misc/ROOT @@ -14,6 +14,7 @@ session Misc = HOL + ListAdditional MultisetAdditional Num_Case_Expression + Quiet_Context Remove_Enum_Discriminate_Elims Result SetAdditional From 68379cbc4994ba78fa2557f631c3a7a463f1f625 Mon Sep 17 00:00:00 2001 From: Ike Mulder Date: Sat, 26 Sep 2026 13:58:55 +0000 Subject: [PATCH 36/46] Make AutoCorrode weakest preconditions resource-exact AutoCorrode's separation assertions mostly described exact resource ownership, but pure assertions and assertion lifting introduced imprecision. Additionally, the WP connective was defined to be closed under ucincl, allowing program proofs to ignore surplus resources. Make pure assertions precise, preserve exactness when lifting assertions, and remove ucincl from weakest preconditions. All resources must now be explicitly accounted for, instead of being silently discarded through upward closure in the WP semantics. can_alloc_reference remains one of the few intentionally ucincl resources so that it can absorb stack-allocated references. Extend crush and seplog to automate reasoning in this exact-resource model. Cancelling a ucincl resource now leaves UNIV in the goal, where it can absorb resources left unmatched by cancellation. Client proofs mostly stay structurally unchanged and only need ucincl-specific steps removed, such as `ucincl_auto` on contracts. A smaller number need adjusting where a residual UNIV conjunct now remains visible in the postcondition. Signed-off-by: Ike Mulder --- Crush/Crush.thy | 2 +- Crush/Examples.thy | 464 ++++++++- Crush/Separation_Logic_Tactics.thy | 39 +- Crush/config.ML | 12 + Crush/crush.ML | 19 +- Crush/seplog.ML | 214 +++- Micro_Rust_Examples/Crush_Examples.thy | 149 ++- Micro_Rust_Examples/Linked_List.thy | 17 +- Micro_Rust_Examples/MLKEM_NTT.thy | 17 +- Micro_Rust_Examples/MLKEM_Polynomial.thy | 10 +- Micro_Rust_Examples/MLKEM_Zq.thy | 3 - Micro_Rust_Examples/Showcase.thy | 21 +- Micro_Rust_Examples/Tutorial.thy | 96 +- Micro_Rust_Interfaces/Global_Perm_Store.thy | 37 +- Micro_Rust_Interfaces/Pair_References.thy | 38 +- .../Raw_Physical_Memory_References.thy | 69 +- Micro_Rust_Interfaces/Read_Write_Resource.thy | 24 +- .../Transfer_Raw_Physical_Memory.thy | 121 ++- Micro_Rust_Interfaces/Transfer_References.thy | 43 +- .../Raw_Physical_Memory.thy | 6 +- Micro_Rust_Interfaces_Core/References.thy | 31 +- Micro_Rust_Runtime/Atomic_Resource.thy | 24 +- .../Raw_Physical_Memory_Trie.thy | 109 +- Micro_Rust_Runtime/Shareable_Resource.thy | 109 +- Micro_Rust_Std_Lib/StdLib_Arithmetic.thy | 30 +- Micro_Rust_Std_Lib/StdLib_Contracts.thy | 107 +- Micro_Rust_Std_Lib/StdLib_Iterators.thy | 2 - Micro_Rust_Std_Lib/StdLib_Option.thy | 13 +- Micro_Rust_Std_Lib/StdLib_Range.thy | 6 +- Micro_Rust_Std_Lib/StdLib_References.thy | 44 +- Micro_Rust_Std_Lib/StdLib_Result.thy | 15 +- Micro_Rust_Std_Lib/StdLib_Slice.thy | 9 +- Separation_Lenses/SLens_Pullback.thy | 726 ++++++++++--- Shallow_Separation_Logic/Adequacy.thy | 61 +- .../Assertion_Language.thy | 961 ++++++++++++------ Shallow_Separation_Logic/Assertion_Triple.thy | 282 ++--- .../Function_Contract.thy | 20 +- Shallow_Separation_Logic/Locality.thy | 2 +- Shallow_Separation_Logic/Precision.thy | 18 +- Shallow_Separation_Logic/Share_Map.thy | 4 +- Shallow_Separation_Logic/Triple.thy | 148 ++- Shallow_Separation_Logic/Weak_Triple.thy | 285 +++--- .../Weakest_Precondition.thy | 462 ++++----- tutorial/Tutorial_SLWorked.thy | 93 +- tutorial/Tutorial_UrustPeek_WP.thy | 32 +- 45 files changed, 3199 insertions(+), 1795 deletions(-) diff --git a/Crush/Crush.thy b/Crush/Crush.thy index bbdea665..f7fe33e1 100644 --- a/Crush/Crush.thy +++ b/Crush/Crush.thy @@ -7,4 +7,4 @@ theory Crush Separation_Logic_Tactics Examples begin -end \ No newline at end of file +end diff --git a/Crush/Examples.thy b/Crush/Examples.thy index ce706632..a67cabb6 100644 --- a/Crush/Examples.thy +++ b/Crush/Examples.thy @@ -152,7 +152,7 @@ subsubsection\Floating assumptions/conclusions\ text\There is tactic support for floating pure assumptions and conclusions:\ -schematic_goal \\ \ \ \ ?\ r \ \\\ \ \ \ \\\ \ \\ r\ \ \\ +schematic_goal \\ \ \ \ ?\ r \ apure (\) \ \ \ apure (\) \ apure (\ r) \ \\ apply (asepconj_rotate_assms) apply (aentails_float_pure_concls) apply (aentails_float_pure_assms) @@ -161,16 +161,16 @@ schematic_goal \\ \ \ \ ?\ r \ \ \' \ :: \'s::sepalg assert\ and P Q R :: \bool\ - have \\ \ \P\ \ \' \ \Q\ \ \R\ \ \P\ \ \Q\ \ \ \ \' \ \R\\ + have \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (P) \ apure (Q) \ \ \ \' \ apure (R)\ by (aentails_float_pure_assms, aentails_float_pure_concls, rule aentails_refl) next fix \ \' \ :: \'s::sepalg assert\ and P Q R :: \bool\ - have \\ \ \P\ \ \' \ \Q\ \ \R\ \ \P\ \ \Q\ \ \ \ \' \ \R\\ + have \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (P) \ apure (Q) \ \ \ \' \ apure (R)\ \\Float assumptions and conclusions at the same time\ by (aentails_float_pure, rule aentails_refl) next fix \ \' \ :: \'s::sepalg assert\ and P Q R :: \bool\ - have \\ \ \P\ \ \' \ \Q\ \ \R\ \ \P\ \ \Q\ \ \ \ \' \ \R\\ + have \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (P) \ apure (Q) \ \ \ \' \ apure (R)\ by (aentails_float_pure, rule aentails_refl) end @@ -276,7 +276,7 @@ traversed using backtracking.\ notepad begin fix \ \' \ :: \'s::sepalg assert\ and P Q R :: \bool\ - have \\ \ \P\ \ \' \ \Q\ \ \R\ \ \P\ \ \Q\ \ \ \ \' \ \R\\ + have \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (P) \ apure (Q) \ \ \ \' \ apure (R)\ apply aentails_float_pure_assms' \\Happens to float \<^verbatim>\R\, but other options are available through backtracking\ back back @@ -290,7 +290,7 @@ next a pure assumption to the front, but only one allows the subsequent application of the introduction rule \<^verbatim>\asepconj_mono\:\ fix \ \' \ :: \'s::sepalg assert\ and P Q R :: \bool\ - have \\ \ \P\ \ \' \ \Q\ \ \R\ \ \Q\ \ \P\ \ \ \ \' \ \R\\ + have \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (Q) \ apure (P) \ \ \ \' \ apure (R)\ \\Backtracking forces floating of \<^verbatim>\Q\, which is not the first choice as we have seen above.\ apply (aentails_float_pure_assms'; intro asepconj_mono) apply aentails_float_pure_assms @@ -317,8 +317,8 @@ begin fix \ \' \ :: \'s::sepalg assert\ and P Q R :: \bool\ assume \ucincl \\ - and 1: \\ \ \' \ \P\ \ \Q\ \ \ \ \' \ \R\\ - from this have \\ \ \P\ \ \' \ \Q\ \ \R\ \ \P\ \ \Q\ \ \ \ \' \ \R\\ + and 1: \\ \ \' \ apure (P) \ apure (Q) \ \ \ \' \ apure (R)\ + from this have \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (P) \ apure (Q) \ \ \ \' \ apure (R)\ apply aentails_hoist_pure_assms apply (rule 1) done @@ -326,16 +326,39 @@ next fix \ \' \ :: \'s::sepalg assert\ and P Q R :: \bool\ assume \ucincl \\ - and 1: \\ \ \P\ \ \' \ \Q\ \ \R\ \ \P\\ - and 2: \\ \ \P\ \ \' \ \Q\ \ \R\ \ \Q\\ - and 2: \\ \ \P\ \ \' \ \Q\ \ \R\ \ \R\\ - and \\ \ \P\ \ \' \ \Q\ \ \R\ \ \ \ \'\ - from this have \\ \ \P\ \ \' \ \Q\ \ \R\ \ \P\ \ \Q\ \ \ \ \' \ \R\\ + and 1: \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (P)\ + and 2: \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (Q)\ + and 2: \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (R)\ + and \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ \ \ \'\ + from this have \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (P) \ apure (Q) \ \ \ \' \ apure (R)\ apply aentails_hoist_pure_concls apply auto done end +text\Ordinary pure-conclusion hoisting declines when the retained +assertion has no closure licence.\ +lemma + fixes \ \ :: \'s::sepalg assert\ and P :: bool + shows \\ \ apure (P) \ \\ + apply (fails \aentails_hoist_pure_concls\) + oops + +text\Precise pure assumptions own zero, so their hoist needs no closure +premise and leaves no residual resource. \<^verbatim>\crush_boot\ applies this method +to exact contract preconditions.\ + +notepad +begin + fix \ \' \ :: \'s::sepalg assert\ + and P Q :: \bool\ + assume 1: \P \ Q \ \ \ \' \ \\ + have \\ \ \P\ \ \' \ \Q\ \ \\ + apply aentails_hoist_pure_precise_assms + apply (rule 1; assumption) + done +end + subsubsection\Hoisting existentials from separating assumptions\ text\When the LHS of a separating entailment contains \\(range ...)\ components @@ -478,6 +501,375 @@ lemma end +subsubsection\Discarding assumptions during cancellation\ + +text\Cancellation drops unmatched assumptions only under a closed +\<^term>\discardable_in\ obligation. An upwards-closed retained context absorbs their resource:\ + +notepad +begin + fix \ \ :: \'s::sepalg assert\ + assume \ucincl \\ + from this have \\ \ \ \ \\ + by aentails_simp_basic +next + \\A factor entailing \<^term>\emp\ owns no resource, so no closure property of + \<^term>\\\ is needed.\ + fix \ \ :: \'s::sepalg assert\ + assume \\ \ emp\ + from this have \\ \ \ \ \\ + by aentails_simp_basic +next + \\A precise pure factor supplies the zero-ownership licence directly.\ + fix \ :: \'s::sepalg assert\ and P :: \bool\ + have \\ \ \P\ \ \\ + by aentails_simp_basic +end + +text\\<^verbatim>\discardable_in_tac\ closes a disposal licence or fails; it never exposes a +separating-entailment fallback to its caller.\ + +lemma + fixes \ \ :: \'s::sepalg assert\ + shows \discardable_in \ \\ + apply (tactic \Separation_Logic_Tactics.discardable_in_tac @{context} 1\ + | log "discardable_in_tac declined an unlicensed disposal") + oops + +subsubsection\Cancellation policy regressions\ + +text\The oracle is opaque to Crush. Its destructor closes a control +only when automation leaves the expected goal unchanged.\ +definition crush_test_oracle :: \bool \ bool\ where + \crush_test_oracle P \ P\ + +lemma crush_test_oracleD: + assumes expected: \crush_test_oracle P\ + shows P + using expected unfolding crush_test_oracle_def . + +context + fixes \ \ \ \ :: \'a::sepalg assert\ + assumes uc_gamma: \ucincl \\ +begin + +text\Each regression supplies only its local closure witness. Both +conjunction orientations are registered globally, so Crush can find +\<^term>\\\ in any retained factor position.\ + +lemma cancel_policy_refl_single: + shows \\ \ \\ + by crush_base + +lemma cancel_policy_refl_three_factors: + shows \\ \ \ \ \ \ \ \ \ \ \\ + by crush_base + +text\A sole retained factor is itself the disposal context.\ +lemma cancel_policy_absorb_into_sole_rhs_factor: + shows \\ \ \ \ \ \ \\ + supply uc_gamma [ucincl_intros] + by crush_base + +lemma cancel_policy_absorb_into_sole_rhs_factor_right: + shows \\ \ \ \ \\ + supply uc_gamma [ucincl_intros] + by crush_base + +text\\<^term>\\\ absorbs unmatched resource, including when it is +already present on the right.\ +lemma cancel_policy_everything_entails_top: + shows \\ \ \ \ \\ + by crush_base + +lemma cancel_policy_rhs_already_has_top: + shows \\ \ \ \ \ \ \\ + by crush_base + +lemma cancel_policy_rhs_already_has_top_mixed: + shows \\ \ \ \ \ \ \ \ \ \ \\ + supply uc_gamma [ucincl_intros] + by crush_base + +text\The retained conjunction is upwards-closed through +\<^term>\\\, so cancellation can discard an extra factor independently +of factor order.\ +lemma cancel_policy_mixed_rhs_absorber_first: + shows \\ \ \ \ \ \ \ \ \\ + supply uc_gamma [ucincl_intros] + by crush_base + +lemma cancel_policy_mixed_rhs_absorber_last: + shows \\ \ \ \ \ \ \ \ \\ + supply uc_gamma [ucincl_intros] + by crush_base + +lemma cancel_policy_mixed_rhs_absorber_middle: + shows \\ \ \ \ \ \ \ \ \ \ \ \ \\ + supply uc_gamma [ucincl_intros] + by crush_base + +lemma cancel_policy_mixed_rhs_lhs_reordered: + shows \\ \ \ \ \ \ \ \ \\ + supply uc_gamma [ucincl_intros] + by crush_base + +text\A schematic in another right-hand factor must not prevent the +concrete upwards-closed factor from providing an absorber for cancellation.\ +schematic_goal cancel_policy_rhs_schematic_after_absorber: + fixes F :: \'b \ 'a assert\ and witness :: 'b + shows \\ \ F witness \ \ \ \ \ F ?x\ + supply uc_gamma [ucincl_intros] + by crush_base + +text\If the selected factor itself is schematic, top insertion declines +instead of asking closure search to choose the assertion's shape.\ +schematic_goal cancel_policy_top_insertion_declines_unknown_factor: + shows \\ \ ?\ \ \\ + apply (fails \tactic \Separation_Logic_Tactics.aentails_insert_top_tac + @{context} 1\\) + oops + +text\The absorber remains available while Crush simplifies a selected branch, +chooses its witness, and discharges exact pure results.\ +lemma cancel_policy_mixed_rhs_exact_result: + fixes witness :: 'b and P :: \'b \ bool\ + assumes \P witness\ + shows \\ \ \ \ + \ \ (if True then + (\x. \Some witness = Some x\ \ \P x\) + else \False\)\ + supply uc_gamma [ucincl_intros] + using assms by crush_base + +lemma cancel_policy_mixed_rhs_exact_error: + fixes witness :: 'b + shows \\ \ \ \ + \ \ (if False then \False\ + else \Some witness = Some witness\)\ + supply uc_gamma [ucincl_intros] + by crush_base + +text\These goals have no licence to discard or invent resource and must +remain open.\ +lemma cancel_policy_control_no_upwards_closed_factor: + assumes expected: + \crush_test_oracle (\ \ \ \ \)\ + shows \\ \ \ \ \\ + apply (crush_base?) + by (rule crush_test_oracleD[OF expected]) + +lemma cancel_policy_control_no_upwards_closed_factor_right: + assumes expected: + \crush_test_oracle (\ \ \ \ \)\ + shows \\ \ \ \ \\ + apply (crush_base?) + by (rule crush_test_oracleD[OF expected]) + +text\Upwards-closure does not create a matching assertion on the left.\ +lemma cancel_policy_control_nothing_to_cancel: + assumes expected: \crush_test_oracle (\ \ \)\ + shows \\ \ \\ + supply uc_gamma [ucincl_intros] + apply (crush_base?) + by (rule crush_test_oracleD[OF expected]) + +text\Upwards closure can justify discarding unused resources from the +left-hand side, but it cannot add an unrelated assertion to the right. If +Crush inserts \<^term>\\\ while trying cancellation, a remaining right-hand +\<^term>\\\ is left as a visible residual rather than removed by a final +fallback.\ +lemma cancel_policy_control_absorber_not_in_lhs: + assumes expected: + \crush_test_oracle (\ \ \ \ \)\ + shows \\ \ \ \ \ \ \\ + supply uc_gamma [ucincl_intros] + apply (crush_base?) + by (rule crush_test_oracleD[OF expected]) + +end + +subsubsection\Conjunction weakening and disposal regressions\ + +text\These regressions exercise conjunction weakening and disposal through +the public Crush loop. Distinct rule heads force the spatial crule path, +including its transactional disposal check.\ + +context + fixes \ \ \ :: \'a::sepalg assert\ +begin + +lemma mono7_cancel_introduces_zero_owned_factor: + assumes P + shows \\ \ \ \ \P\\ + using assms by crush_base + +lemma mono7_cancel_discards_nested_zero_owned_factor: + shows \\ \ (\P\ \ emp) \ \\ + by crush_base + +lemma mono7_crule_introduces_zero_owned_factor: + assumes rewrite: \\ \ \\ + and P + shows \\ \ \ \ \P\\ + using assms by (crush_base seplog crule add: rewrite) + +lemma mono7_crule_discards_zero_owned_factor: + assumes rewrite: \Q \ \ \ \\ + and Q + shows \\ \ \P\ \ \\ + using assms by (crush_base seplog crule add: rewrite) + +text\An unlicensed disposal rejects the complete crule alternative.\ +lemma mono7_crule_rejects_unlicensed_disposal: + assumes rewrite: \Q \ \ \ \\ + and Q + and expected: \crush_test_oracle (\ \ \ \ \)\ + shows \\ \ \ \ \\ + supply rewrite [crush_aentails_crules] + apply (crush_base?) + by (rule crush_test_oracleD[OF expected]) + +end + +text\Rigid value expressions prevent generic unification from taking the +positive goal, so it exercises legacy injective cancellation. When disposal +is unlicensed, legacy splitting exposes the exact frame obligation while +non-legacy cancellation leaves the original entailment.\ + +context reference +begin + +lemma mono7_legacy_points_to_discards_zero_owned_factor: + assumes g_eq: \g_left x = g_right y\ + and v_eq: \v_left x = v_right y\ + shows \points_to r sh (g_left x) (v_left x) \ \P\ + \ points_to r sh (g_right y) (v_right y)\ + supply [[crush_enable_legacy_points_to_tactic = true]] + using assms by crush_base + +lemma mono7_legacy_points_to_leaves_exact_frame_residual: + assumes expected: + \crush_test_oracle (A \ B \ emp)\ + shows \A \ points_to r sh g v \ B + \ points_to r sh g v\ + supply [[crush_enable_legacy_points_to_tactic = true]] + apply (crush_base?) + by (rule crush_test_oracleD[OF expected]) + +lemma mono7_nonlegacy_points_to_leaves_original_residual: + assumes expected: + \crush_test_oracle + (A \ points_to r sh g v \ B \ points_to r sh g v)\ + shows \A \ points_to r sh g v \ B + \ points_to r sh g v\ + supply [[crush_enable_legacy_points_to_tactic = false]] + apply (crush_base?) + by (rule crush_test_oracleD[OF expected]) + +end + +subsubsection\Upwards-closure search\ + +context + fixes \ \ \ \ :: \'s::sepalg assert\ + assumes uc_gamma: \ucincl \\ +begin + +text\\<^verbatim>\ucincl_solve\ searches both conjunction orientations and +accepts only a branch that closes the selected goal.\ + +lemma ucincl_solve_left_factor: + shows \ucincl (\ \ \)\ + supply uc_gamma [ucincl_intros] + by ucincl_solve + +lemma ucincl_solve_right_factor: + shows \ucincl (\ \ \)\ + supply uc_gamma [ucincl_intros] + by ucincl_solve + +lemma ucincl_solve_nested_factor: + shows \ucincl ((\ \ \) \ (\ \ \))\ + supply uc_gamma [ucincl_intros] + by ucincl_solve + +end + +subsubsection\UNIV normalization and right-hand binder introduction\ + +context + fixes P :: \'i \ 's::sepalg assert\ + and \ \ \ :: \'s assert\ +begin + +text\Crush introduces a universal quantifier on the right before +instantiating one on the left. This lets the left-hand witness depend on the +variable introduced on the right.\ +lemma aforall_dependency_after_emp: + shows \(\x. P x) \ emp \ (\y. P y)\ + by crush_base + +lemma aforall_factor_dependency_after_emp: + shows \(\x. P x) \ \ \ + emp \ (\y. P y \ \)\ + by crush_base + +text\When a universal quantifier on the right is preceded by +\<^term>\\\, Crush introduces the quantified variable without carrying the +\<^term>\\\ into the new subgoal. This also works when several scattered +\<^term>\\\ assertions must first be normalized to one leading +\<^term>\\\.\ +lemma aforall_dependency_under_top: + shows \(\x. P x) \ \ \ (\y. P y)\ + by crush_base + +lemma aforall_dependency_under_scattered_tops: + shows \(\x. P x) \ (\y. P y) \ \ \ \\ + by crush_base + +text\An intersection preceded by \<^term>\\\ is split without +carrying \<^term>\\\ into either subgoal.\ +lemma aentails_int_intro_under_top: + assumes \\ \ \\ + and \\ \ \\ + shows \\ \ \ \ (\ \ \)\ + using assms by crush_base + +text\A dedicated rule likewise introduces a right-hand wand preceded by +\<^term>\\\, without carrying the \<^term>\\\ into the resulting +subgoal.\ +lemma awand_intro_under_top: + shows \\ \ \ \ (\ \ (\ \ \))\ + by crush_base + +text\Crush no longer removes a remaining right-hand \<^term>\\\ as a final +fallback.\ +lemma no_final_top_removal: + assumes expected: + \crush_test_oracle (\ \ \ \ \)\ + shows \\ \ \ \ \\ + apply (crush_base?) + by (rule crush_test_oracleD[OF expected]) + +end + +subsubsection\Undetermined witnesses in an upwards-closure obligation\ + +text\\<^verbatim>\ucincl_solve\ uses a final \<^verbatim>\clarsimp\ only on schematic-free +subgoals. A schematic surviving its bounded search is an undetermined witness, +so the tactic leaves it to the caller. The conclusion of +\<^verbatim>\asepconj_multi_ucincl_member\ does not determine its factor witness; the +test below requires \<^verbatim>\ucincl_solve\ to decline that residual obligation:\ + +lemma + fixes \ :: \'s::sepalg assert multiset\ + shows \ucincl (\\\)\ + apply (rule asepconj_multi_ucincl_member) + prefer 2 \\the upwards-closure obligation on the factor still to be chosen\ + apply (fails \ucincl_solve\) + oops + subsubsection\Entailment simplification\ text\\<^verbatim>\aentails_simp_core\ attempts a single simplification step for a separating entailment. @@ -488,8 +880,7 @@ notepad begin fix \ \' \ :: \'s::sepalg assert\ and P Q R :: \bool\ assume \ucincl \\ - from this have \\ \ \P\ \ \' \ \Q\ \ \R\ \ \P\ \ \Q\ \ \ \ \' \ \R\\ - apply aentails_simp_core \\Floating assumptions and conclusions\ + from this have \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (P) \ apure (Q) \ \ \ \' \ apure (R)\ apply aentails_simp_core \\Hoisting pure assumptions\ apply aentails_simp_core \\Splitting pure conclusions\ apply aentails_simp_core @@ -503,7 +894,7 @@ begin next fix \ \' \ :: \'s::sepalg assert\ and P Q R :: \bool\ assume \ucincl \\ - from this have \\ \ \P\ \ \' \ \Q\ \ \R\ \ \P\ \ \Q\ \ \ \ \' \ \R\\ + from this have \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (P) \ apure (Q) \ \ \ \' \ apure (R)\ \\The same again, but now in one step\ by aentails_simp_basic end @@ -519,19 +910,41 @@ notepad begin fix \ \ \ :: \'s::sepalg assert\ and P Q R :: \bool\ assume \ucincl \\ - from this have \P \ \ \ \Q\ \ \ \ \R\ \ \ \ \ \ \P\ \ \Q\ \ \ \ \ \ \R\\ + from this have \P \ \ \ apure (Q) \ \ \ apure (R) \ \ \ \ \ apure (P) \ apure (Q) \ \ \ \ \ apure (R)\ by aentails_simp_basic next \\Note, however, that classical simplification is not performed:\ fix \ \ \ :: \'s::sepalg assert\ and P Q R :: \bool\ assume \ucincl \\ - from this have \P \ \ \ \Q\ \ \ \ \R\ \ \ \ \ \ \P \ Q\ \ \ \ \ \ \R\\ + from this have \P \ \ \ apure (Q) \ \ \ apure (R) \ \ \ \ \ apure (P \ Q) \ \ \ \ \ apure (R)\ apply aentails_simp_basic apply simp apply aentails_simp_basic done end +subsubsection\Precise pure assertions\ + +text\The precise-pure hoists need no closure premise. On the conclusion +side they leave a separating entailment against \<^term>\apure (P)\, allowing later +spatial branches to continue. These examples exercise both directions through +the public core method.\ + +notepad +begin + fix \ :: \'s::sepalg assert\ and P :: bool + have \\P\ \ \ \ \\ + apply aentails_simp_core + by (simp add: aentails_refl) +next + fix \ \ :: \'s::sepalg assert\ and P :: bool + assume \P\ + have \\ \ \ \ \P\ \ \ \ \\ + apply aentails_simp_core + apply (rule apure_entailsR0[OF \P\]) + by (rule aentails_refl) +end + subsubsection\Spatial \<^verbatim>\rule\\ lemma @@ -596,6 +1009,11 @@ Conditional crules subsume ordinary spatial rules/drules and plain crules: consumed from the conclusions, \\\ is produced as the result, and \R\ is added alongside it on the RHS. +The connective itself imposes no closure obligation on its result. A derived +rule with no conclusion slot for produced resource must instead license that +resource's disposal. For \aentails_conditional_crule_R0\, \ucincl \\ is +equivalent to disposing of the \UNIV\ residue while retaining \\\. + Below we demonstrate \aentails_cond_crule\ in general form, then as a plain crule, and finally in the drule-like and rule-like degenerate forms.\ @@ -686,7 +1104,7 @@ lemma subsubsection\Strong conditional spatial \crule\\ text\The \<^emph>\strong\ variant \\ [L]\\<^sub>s[R] \\ is defined as -\\ \ R \ (L \ \) \ ucincl \\, internalising the \L\-to-\R\ exchange using the +\\ \ R \ (L \ \)\, internalising the \L\-to-\R\ exchange using the magic wand. Operationally, when the ordinary variant succeeds in closing the goal by producing \R \ (L \ G)\ on the conclusions, the strong variant succeeds under the weaker condition that the \L\-consumption and the \R\-production can be @@ -705,6 +1123,14 @@ The distinction only matters when \<^emph>\both\ \L\ a variant's wand-internalisation allows the residue to be closed more directly.\ +lemma awand_mp_strong_crule_backward: + fixes \ \ :: \'s::sepalg assert\ + assumes uc_alpha: \ucincl \\ + shows \(\ \ \) \ (\ \ \) \ \\ + supply uc_alpha [ucincl_intros] + by (crush_base + seplog cond crule add: awand_mp_strong_crule) + subsection\Saturating unfolding of definitions\ notepad diff --git a/Crush/Separation_Logic_Tactics.thy b/Crush/Separation_Logic_Tactics.thy index 1ada352f..e9a1dc39 100644 --- a/Crush/Separation_Logic_Tactics.thy +++ b/Crush/Separation_Logic_Tactics.thy @@ -433,23 +433,18 @@ method aentails_cancel_points_to_raw_with_typed = guard \K Separation_Logi (rule refl | simp)?) \ -\\Turn pure separating conclusions into pure HOL subgoals\ -method aentails_hoist_pure_concls = - (aentails_float_pure_concls?, intro apure_entailsR) - -(* TODO: This is out of sync with the _tactic_ `aentails_simp_core_tac` *) -method aentails_simp_core = ( - time "aentails_simp_core_float" aentails_float_pure -| time "aentails_simp_core_intro_pure_assms" \ucincl_discharge \intro apure_entailsL0 apure_entailsL\\ -| time "aentails_simp_core_intro_pure_concls" \ucincl_discharge \intro apure_entailsR\\ -| time "aentails_simp_core_intro_others" \ucincl_discharge \intro - aforall_entailsL aforall_entailsR aexists_entailsL aentails_refl - aentails_top_L aentails_top_R bot_aentails_all all_aentails_true\\ -| time "aentails_simp_core_simps" \ucincl_discharge \simp (no_asm_simp) only: asepconj_simp\\ -| guard \fn ctxt => K (Config.get ctxt Crush_Config.enable_branch_split)\ \ - time "aentails_simp_core_split" \intro aentails_disj_L0\ - \ -) +\\Ordinary pure conclusions can be split only when the retained +conclusion absorbs the separated resource.\ +method_setup aentails_hoist_pure_concls = \ + Scan.succeed + (SIMPLE_METHOD' o Separation_Logic_Tactics.aentails_hoist_pure_concls_tac) +\ + +\\The public method uses the same implementation as the Crush +entailment loop.\ +method_setup aentails_simp_core = \ + Scan.succeed (SIMPLE_METHOD' o Separation_Logic_Tactics.aentails_simp_core_tac) +\ method_setup aentails_cancel_tac = \ Scan.succeed (SIMPLE_METHOD' o Separation_Logic_Tactics.aentails_cancel_tac) @@ -467,11 +462,15 @@ method contract uses f contract = subst wp_sstriple_iff, ( simp (no_asm) only: contract )? ) +\\Run the ordinary hoist first so it can consolidate its factors, then +hoist precise-pure factors. Both are optional, allowing mixed contract +preconditions.\ method crush_boot uses f contract simp = (contract f:f contract:contract, micro_rust_ssa_wp_normalize, (clarsimp simp add: Let_def simp)?, - aentails_hoist_pure_assms?) + aentails_hoist_pure_assms?, + aentails_hoist_pure_precise_assms?) section\\<^verbatim>\crush\\ @@ -484,6 +483,10 @@ declare asepconj_Inf_distrib [crush_asepconj_simp] declare asepconj_Inf_distrib2 [crush_asepconj_simp] declare asepconj_UNIV_idempotent[crush_asepconj_simp] declare awand_pure_false [crush_asepconj_simp] +declare asepconj_emp_unit [crush_asepconj_simp] +\\Do not normalize precise falsehood here: the core hoist turns that +factor directly into a \<^term>\False\ premise, while \<^term>\\ \ \\ would stall the loop.\ +declare apure_precise_True [crush_asepconj_simp] declare refl[crush_intros add] diff --git a/Crush/config.ML b/Crush/config.ML index 0c0ccbea..5177e657 100644 --- a/Crush/config.ML +++ b/Crush/config.ML @@ -13,8 +13,12 @@ sig val time_guards : bool Config.T (* profile time of ucincl discharge *) val time_ucincl : bool Config.T + (* profile time of discardability discharge *) + val time_discardable_in : bool Config.T (* profile time of separating entailment cancellation *) val time_aentails_cancel : bool Config.T + (* profile time of the \-insertion which precedes cancellation *) + val time_insert_top : bool Config.T (* profile time of separating entailment core tactic *) val time_aentails_core : bool Config.T (* profile time simplification branch *) @@ -46,6 +50,8 @@ sig val log_calls : bool Config.T (* log ucincl discharge *) val log_ucincl : bool Config.T + (* log discardability discharge *) + val log_discardable_in : bool Config.T (* log schematic variable instantiations performed by each crush branch *) val log_schematics : bool Config.T (* pause after each schematic instantiation and prompt the user *) @@ -54,6 +60,8 @@ sig val log_transactions : bool Config.T (* log crush setup time *) val log_aentails_cancel : bool Config.T + (* log the \-insertion which precedes cancellation *) + val log_insert_top : bool Config.T val log_aentails_core : bool Config.T val log_base_simps : bool Config.T @@ -110,8 +118,10 @@ struct val time_steps = Attrib.setup_config_bool @{binding "crush_time_steps"} (K false) val time_guards = Attrib.setup_config_bool @{binding "crush_time_guards"} (K false) val time_ucincl = Attrib.setup_config_bool @{binding "crush_time_ucincl"} (K false) + val time_discardable_in = Attrib.setup_config_bool @{binding "crush_time_discardable_in"} (K false) val time_clarsimp = Attrib.setup_config_bool @{binding "crush_time_clarsimp"} (K false) val time_aentails_cancel = Attrib.setup_config_bool @{binding "crush_time_aentails_cancel"} (K false) + val time_insert_top = Attrib.setup_config_bool @{binding "crush_time_insert_top"} (K false) val time_aentails_core = Attrib.setup_config_bool @{binding "crush_time_aentails_core"} (K false) val time_unfold_prems = Attrib.setup_config_bool @{binding "crush_time_unfold_prems"} (K false) val time_calls = Attrib.setup_config_bool @{binding "crush_time_calls"} (K false) @@ -127,9 +137,11 @@ struct val log_clarsimp = Attrib.setup_config_bool @{binding "crush_log_clarsimp"} (K false) val log_calls = Attrib.setup_config_bool @{binding "crush_log_calls"} (K true) val log_ucincl = Attrib.setup_config_bool @{binding "crush_log_ucincl"} (K false) + val log_discardable_in = Attrib.setup_config_bool @{binding "crush_log_discardable_in"} (K false) val log_schematics = Attrib.setup_config_bool @{binding "crush_log_schematics"} (K false) val ask_schematics = Attrib.setup_config_bool @{binding "crush_ask_schematics"} (K false) val log_aentails_cancel = Attrib.setup_config_bool @{binding "crush_log_aentails_cancel"} (K false) + val log_insert_top = Attrib.setup_config_bool @{binding "crush_log_insert_top"} (K false) val log_aentails_core = Attrib.setup_config_bool @{binding "crush_log_aentails_core"} (K false) val log_base_simps = Attrib.setup_config_bool @{binding "crush_log_base_simps"} (K false) diff --git a/Crush/crush.ML b/Crush/crush.ML index 4c69c48f..44db43c4 100644 --- a/Crush/crush.ML +++ b/Crush/crush.ML @@ -77,6 +77,7 @@ sig val crush_branch_aentails_cancel_tac : Proof.context -> int -> tactic val crush_branch_unfold_prems_tac : Proof.context -> int -> tactic val crush_branch_aentails_core_tac : Proof.context -> int -> tactic + val crush_branch_aentails_aforall_assms_tac : Proof.context -> int -> tactic val crush_branch_determine_branch : Proof.context -> int -> tactic val crush_branch_aentails_drule_tac : Proof.context -> int -> tactic val crush_branch_aentails_crule_tac : Proof.context -> int -> tactic @@ -355,8 +356,15 @@ struct Separation_Logic_Tactics.aentails_simp_core_tac ctxt ) ) + val crush_branch_aentails_aforall_assms_tac : Proof.context -> int -> tactic = fn ctxt => + IF' Separation_Logic_Tactics.is_entailment ( + Separation_Logic_Tactics.aentails_simp_core_intro_aforall_assms_tac ctxt + ) + val crush_branch_aentails_cancel_tac : Proof.context -> int -> tactic = fn ctxt => - IF' Separation_Logic_Tactics.is_entailment (Separation_Logic_Tactics.aentails_cancel_tac ctxt) + IF' Separation_Logic_Tactics.is_entailment ( + Separation_Logic_Tactics.aentails_cancel_tac ctxt + ) fun crush_branch_schematics_tac (ctxt: Proof.context) (unfold_contract_tac: int -> tactic) : int -> tactic = let val ex_intros = intro_tac (Named_Theorems.get ctxt @{named_theorems micro_rust_wp_ex_intros}) ctxt @@ -494,7 +502,8 @@ struct end val crush_branch_intro_pure_aentails_tac : Proof.context -> int -> tactic = fn ctxt => - Separation_Logic_Tactics.ucincl_discharge_tac ctxt (intro_tac @{thms apure_entailsR0} ctxt) + Separation_Logic_Tactics.ucincl_discharge_tac ctxt + (intro_tac @{thms apure_entailsR0 apure_precise_entailsR0} ctxt) val crush_branch_aentails_cond_crule_tac = fn ctxt => Separation_Logic_Tactics.aentails_cond_crule_tac (Named_Theorems.get ctxt @{named_theorems crush_aentails_cond_crules}) ctxt @@ -519,6 +528,8 @@ struct post_step_tac = NONE } ); + val crush_branch_discardable_in_tac = Separation_Logic_Tactics.discardable_in_tac + val crush_branch_ucincl_tac = Separation_Logic_Tactics.ucincl_solve_tac val crush_branch_additional_tactic: Proof.context -> int -> tactic = fn ctxt => @@ -579,7 +590,10 @@ struct ("intro_pure_aentails_tac" , \<^here>, (fn _ => crush_branch_intro_pure_aentails_tac ctxt)), ("urust_simps_tac" , \<^here>, (fn _ => crush_branch_urust_simps_tac ctxt)), ("clarsimp_tac" , \<^here>, (fn _ => crush_branch_clarsimp_tac ctxt)), + ("aentails_aforall_assms_tac", \<^here>, + (fn _ => crush_branch_aentails_aforall_assms_tac ctxt)), ("misc_tac" , \<^here>, (fn _ => crush_branch_misc_tac ctxt)), + ("discardable_in_tac" , \<^here>, (fn _ => crush_branch_discardable_in_tac ctxt)), ("ucincl_tac" , \<^here>, (fn _ => crush_branch_ucincl_tac ctxt)), ("additional_tac" , \<^here>, (fn _ => crush_branch_additional_tactic ctxt)), ("additional_method" , \<^here>, (fn _ => crush_branch_additional_method ctxt)), @@ -808,6 +822,7 @@ struct make_log_parser "clarsimp" Crush_Config.log_clarsimp, make_log_parser "calls" Crush_Config.log_calls, make_log_parser "ucincl" Crush_Config.log_ucincl, + make_log_parser "discardable_in" Crush_Config.log_discardable_in, make_log_parser "schematics" Crush_Config.log_schematics, make_arg_parser' (Args.$$$ "ask" -- Args.$$$ "schematics") Parser.parse_bool (Config.put Crush_Config.ask_schematics) \<^here>] diff --git a/Crush/seplog.ML b/Crush/seplog.ML index b81c2b8f..f3156eae 100644 --- a/Crush/seplog.ML +++ b/Crush/seplog.ML @@ -378,6 +378,10 @@ sig val aentails_float_pure_concls_tac' : Proof.context -> int -> tactic \ \Moves pure assumptions and conclusions in a separating entailment to the left most position(s)\ val aentails_float_pure_tac : Proof.context -> int -> tactic + \ \Moves precise pure assumptions in a separating entailment to the leftmost position(s)\ + val aentails_float_pure_precise_assms_tac : Proof.context -> int -> tactic + \ \Moves precise pure conclusions in a separating entailment to the leftmost position(s)\ + val aentails_float_pure_precise_concls_tac : Proof.context -> int -> tactic \ \Moves typed points_to assumptions in a separating entailment to the leftmost position(s)\ val aentails_float_points_to_assms_tac : Proof.context -> int -> tactic \ \Moves typed points_to assumptions in a separating entailment to the leftmost position(s); @@ -411,9 +415,18 @@ sig val aentails_hoist_pure_assms_tac : Proof.context -> int -> tactic val aentails_hoist_pure_concls_tac : Proof.context -> int -> tactic + \\Hoist zero-owning pure assumptions without a closure condition.\ + val aentails_hoist_pure_precise_assms_tac : Proof.context -> int -> tactic + \\Split zero-owning pure conclusions without a closure condition.\ + val aentails_hoist_pure_precise_concls_tac : Proof.context -> int -> tactic \\Hoist \(range ...) out of the LHS of an entailment, then intro \<^verbatim>\aexists_entailsL\.\ val aentails_hoist_existential_assms_tac : Proof.context -> int -> tactic + \\Move literal \<^term>\\\ assertions to the front of each side of an + entailment and merge duplicates.\ + val aentails_canonicalize_top_tac : Proof.context -> int -> tactic + val aentails_simp_core_intro_concls_tac : Proof.context -> int -> tactic val aentails_simp_core_intro_others_tac : Proof.context -> int -> tactic + val aentails_simp_core_intro_aforall_assms_tac : Proof.context -> int -> tactic val aentails_simp_core_cancel_univ_prems : Proof.context -> int -> tactic val aentails_simp_core_tac : Proof.context -> int -> tactic @@ -437,6 +450,9 @@ sig entailment, and cancels them. This is essentially \<^verbatim>\float_match\ for \<^verbatim>\is_unifiable_pair\, plus a cancellation lemma.\ val aentails_cancel_core_tac : Proof.context -> int -> tactic + \ \Inserts \<^verbatim>\\\ after the first right-hand factor when that factor is + upwards-closed, making it an absorber for subsequent cancellation.\ + val aentails_insert_top_tac : Proof.context -> int -> tactic \ \Identifies and cancels matching pairs of iterated separating conjunctions.\ val aentails_cancel_asepconj_multi: Proof.context -> int -> tactic \ \Identifies pairs of separating assumptions and conclusions which are both applications of the @@ -504,6 +520,11 @@ sig val ucincl_discharge_method : Method.method -> Method.method + \ \Automatic discharge of \<^verbatim>\discardable_in\ conditions.\ + + \\Close a \<^verbatim>\discardable_in\ goal or fail without changing its shape.\ + val discardable_in_tac : Proof.context -> int -> tactic + \ \Solves the first goal if it is an equality between permuted separating conjunctions\ val asepconj_solve_eq_tac : Proof.context -> int -> tactic @@ -836,12 +857,19 @@ struct fun dest_pure ((Const (@{const_name apure}, _)) $ t) = t | dest_pure _ = raise SeparationLogic "dest_pure" + fun dest_pure_precise ((Const (@{const_name apure_precise}, _)) $ t) = t + | dest_pure_precise _ = raise SeparationLogic "dest_pure_precise" + + fun dest_discardable_in ((Const (@{const_name discardable_in}, _)) $ d $ r) = (d, r) + | dest_discardable_in _ = raise SeparationLogic "not a discardable_in proposition" + val dest_asepconj_multi_mapped = dest_asepconj_multi #> dest_mapped_multiset val unwrap_aentails = find_metaimp_conclusion #> dest_aentails val unwrap_wp_aentails = unwrap_aentails #> snd #> dest_wp val unwrap_wp_call = unwrap_wp_aentails #> #2 #> dest_urust_call val unwrap_ucincl = find_metaimp_conclusion #> dest_ucincl + val unwrap_discardable_in = find_metaimp_conclusion #> dest_discardable_in fun dest_Const_or_Free (Const x) = x | dest_Const_or_Free (Free x) = x @@ -857,11 +885,13 @@ struct val is_entailment = succeeds unwrap_aentails val is_wp_entailment = succeeds unwrap_wp_aentails val is_ucincl = succeeds unwrap_ucincl + val is_discardable_in = succeeds unwrap_discardable_in val is_points_to = succeeds dest_points_to val is_points_to_raw = succeeds dest_points_to_raw val is_asepconj = succeeds dest_asepconj val is_asepconj_multi = succeeds dest_asepconj_multi val is_pure = succeeds dest_pure + val is_pure_precise = succeeds dest_pure_precise val is_wp_call = succeeds unwrap_wp_call fun conjunction_of (filter : term -> bool) : term -> bool = find_conclusions #> List.all filter @@ -1090,6 +1120,10 @@ struct val ctxt' = ctxt addsimps @{thms Let_def} fun NOTE msg = Fine_Grained_Timing.TIME' ctxt (Config.get ctxt Crush_Config.time_ucincl) msg #> Crush_Tacticals.LOG' ctxt (Config.get ctxt Crush_Config.log_ucincl) msg + (* Full `clarsimp` may instantiate a schematic witness. A schematic surviving the + bounded search is undetermined, so leave that subgoal to the caller. Concrete + fallbacks remain visible through `crush_log_ucincl`. *) + val has_no_schematics = not o Term.exists_subterm Term.is_Var in Crush_Tacticals.IF' is_ucincl ( NOTE "ucincl_solve" ( ( REPEAT_ALL_NEW ( NOTE "ucincl_solve_intro" ucincl_intro @@ -1097,9 +1131,8 @@ struct ORELSE' NOTE "ucincl_solve_clarify" (CHANGED_PROP o clarify_tac ctxt) ORELSE' NOTE "ucincl_solve_safe_simp" (CHANGED_PROP o safe_full_simp_tac ctxt') ORELSE' NOTE "ucincl_solve_safe" (CHANGED_PROP o safe_steps_tac ctxt) - ORELSE' ((print_tac ctxt - "Warning: ucincl_solve trying full-blown clarsimp -- should not be needed?" |> K) - THEN' NOTE "ucincl_solve_clarsimp" (CHANGED_PROP o clarsimp_tac ctxt')) + ORELSE' Crush_Tacticals.IF' has_no_schematics + (NOTE "ucincl_solve_clarsimp" (CHANGED_PROP o clarsimp_tac ctxt')) )))) end @@ -1117,6 +1150,30 @@ struct val ucincl_must_discharge_tac' : (Proof.context -> int -> tactic) -> (Proof.context -> int -> tactic) = fn ct => fn ctxt => ct ctxt THEN_ALL_NEW (IF_OK' is_ucincl (SOLVED' (ucincl_solve_tac ctxt))) + (* Every branch closes the disposal licence or fails, so cancellation commits only to licensed + resource disposal. `intro_tac` also avoids choosing a shape for a schematic discarded factor. *) + fun discardable_in_tac ctxt = + let (* Use a direct licence or a stated zero-ownership entailment. *) + val discardable_in_assm = + assume_tac ctxt + ORELSE' (intro_tac @{thms discardable_in_aentails_empI} ctxt THEN' assume_tac ctxt) + (* Structural zero-ownership rules may decompose the discarded assertion. *) + val discardable_in_intro = + intro_tac (Named_Theorems.get ctxt @{named_theorems discardable_in_intros}) ctxt + THEN_ALL_NEW (TRY o discardable_in_assm) + (* An upwards-closed retained context absorbs the discarded resource. *) + val discardable_in_from_ucincl = + ucincl_must_discharge_tac ctxt (intro_tac @{thms discardable_in_ucinclI} ctxt) + fun NOTE msg = Fine_Grained_Timing.TIME' ctxt (Config.get ctxt Crush_Config.time_discardable_in) msg + #> Crush_Tacticals.LOG' ctxt (Config.get ctxt Crush_Config.log_discardable_in) msg + in Crush_Tacticals.IF' is_discardable_in ( NOTE "discardable_in" ( + NOTE "discardable_in_assm" discardable_in_assm + (* Prefer structural licences. `SOLVED' preserves the closure fallback when + decomposition leaves an unlicensed factor. *) + ORELSE' NOTE "discardable_in_intro" (SOLVED' discardable_in_intro) + ORELSE' NOTE "discardable_in_from_ucincl" discardable_in_from_ucincl)) + end + val ucincl_discharge_method : Method.method -> Method.method = fn m => fn ts => m ts |> context_tactic_to_context_tactic' |> (fn t => SELECT_GOAL o t) @@ -1165,11 +1222,11 @@ struct val ucincl_auto = fold ucincl_auto_single val _ = Outer_Syntax.local_theory_to_proof @{command_keyword "ucincl_proof"} - "open a proof context for upward closure" + "open an upward-closure proof for an assertion or contract" (Parse.embedded >> ucincl_proof) val _ = Outer_Syntax.local_theory @{command_keyword "ucincl_auto"} - "open a proof context for upward closure of a contract's pre/post condition" + "prove upward closure for an assertion or contract" (Scan.repeat1 Parse.embedded >> ucincl_auto) \\Instantiates and applied the theorem \<^term>\thm\ with the transformation of \<^term>\t\ under\<^term>\pi\.\ @@ -1860,6 +1917,10 @@ struct val aentails_float_pure_assms_tac' = aentails_pick_assms_tac' is_pure val aentails_float_pure_concls_tac' = aentails_pick_concls_tac' is_pure + (* Float precise pure factors to the front of a separating conjunction. *) + val aentails_float_pure_precise_assms_tac = aentails_pick_assms_tac'' is_pure_precise + val aentails_float_pure_precise_concls_tac = aentails_pick_concls_tac'' is_pure_precise + (* floating typed points_to relations to the front of a separating conjunction *) val aentails_float_points_to_assms_tac = aentails_pick_assms_tac'' is_points_to @@ -1997,9 +2058,15 @@ struct fun aentails_crule_tac_single (thm : thm) (ctxt : Proof.context) = (aentails_float_crule_tac thm ctxt THEN' ( - resolve_tac ctxt [aentails_crule_core OF [thm], - aentails_crule_coreL OF [thm], - aentails_crule_coreR OF [thm], thm] + (* `aentails_crule_coreR` drops a factor and must close its disposal + premise within this alternative. Composed theorem premises precede + that disposal, so `THEN_LAST` addresses it without counting. + `APPEND'` preserves ordered alternatives and outer backtracking. *) + resolve_tac ctxt [aentails_crule_core OF [thm], + aentails_crule_coreL OF [thm]] + APPEND' (resolve_tac ctxt [aentails_crule_coreR OF [thm]] + THEN_LAST SOLVED' (discardable_in_tac ctxt)) + APPEND' resolve_tac ctxt [thm] handle THM _ => K no_tac )) THEN_LAST (TRY o (aentails_normalize_assoc_concls_tac ctxt)) @@ -2083,11 +2150,14 @@ struct ORELSE (resolve_tac ctxt [@{thm aentails_cancel_multi_0R}] i) ORELSE all_tac) + (* Bare `asepconj_mono7` leaves the matched-factor entailment at `i` and + disposal at `i + 1`. Close the disposal here or reject the alternative. *) fun aentails_cancel_injective match_head arglist ctxt i = aentails_float_match ctxt (matching_injective_assertion ctxt match_head arglist) i THEN ((resolve_tac ctxt [@{thm asepconj_mono4}] i) ORELSE (resolve_tac ctxt [@{thm asepconj_mono6}] i) - ORELSE (resolve_tac ctxt [@{thm asepconj_mono7}] i) + ORELSE (resolve_tac ctxt [@{thm asepconj_mono7}] i + THEN SOLVED' (discardable_in_tac ctxt) (i + 1)) ORELSE all_tac) val solves_reference_axioms : Proof.context -> int -> tactic = @@ -2151,18 +2221,57 @@ struct fn i => [float_concls i, float_assms i] |> map TRY |> EVERY |> CHANGED end + fun is_top (Const (@{const_name top}, _)) = true + | is_top _ = false + + val collapse_leading_top_conv = + Conv.repeat_conv + (Conv.rewrs_conv + (@{thms asepconj_UNIV_collapse_top asepconj_UNIV_idempotent} + |> force_meta_eqs)) + + val aentails_canonicalize_top_tac : Proof.context -> int -> tactic = fn ctxt => + SUBGOAL (fn (goal, i) => + let + val (assms, concls) = unwrap_aentails goal + val has_top = + List.exists is_top (split_asepconj assms @ split_asepconj concls) + val normalize = aentails_normalize_assoc_tac ctxt + val float_concls = aentails_pick_concls_tac'' is_top ctxt + val float_assms = aentails_pick_assms_tac'' is_top ctxt + val collapse = + CONVERSION + (aentails_conv' collapse_leading_top_conv collapse_leading_top_conv ctxt) + in + if has_top then + [normalize i, float_concls i, float_assms i, collapse i] + |> map TRY |> EVERY |> CHANGED + else + no_tac + end + handle SeparationLogic _ => no_tac) + + val aentails_simp_core_intro_concls_tac : Proof.context -> int -> tactic = fn ctxt => + intro_tac @{thms aentails_intI_top + aforall_entailsR_top aforall_entailsR + awand_emp_adjointI_top awand_adjointI_top + awand_emp_adjointI awand_adjointI} ctxt + val aentails_simp_core_intro_others_tac : Proof.context -> int -> tactic = fn ctxt => - intro_tac @{thms aforall_entailsL aforall_entailsR aexists_entailsL - aentails_refl all_aentails_true aentails_top_R aentails_top_R' - bot_aentails_all awand_adjointI aentails_intI aentails_true} ctxt + intro_tac @{thms aexists_entailsL aentails_refl all_aentails_true + bot_aentails_all aentails_intI aentails_true} ctxt + + val aentails_simp_core_intro_aforall_assms_tac : Proof.context -> int -> tactic = fn ctxt => + intro_tac @{thms aforall_entailsL} ctxt + ORELSE' aentails_drule_tac_single @{thm aentails_forallL} ctxt val aentails_simp_core_cancel_univ_prems : Proof.context -> int -> tactic = fn ctxt => ucincl_must_discharge_tac ctxt (intro_tac @{thms aentails_top_L aentails_top_L'} ctxt) val aentails_simp_core_simps_tac : Proof.context -> int -> tactic = fn ctxt => - let val asepconj_simps = Named_Theorems.get ctxt @{named_theorems crush_asepconj_simp} in - safe_simp_no_asm_simp_only_tac ctxt asepconj_simps - end + let val asepconj_simps = Named_Theorems.get ctxt @{named_theorems crush_asepconj_simp} in + safe_simp_no_asm_simp_only_tac ctxt asepconj_simps + end val aentails_simp_core_split_tac : Proof.context -> int -> tactic = fn ctxt => if Config.get ctxt Crush_Config.enable_branch_split then @@ -2182,27 +2291,44 @@ struct (* split the newly introduced pure premise *) THEN' TRY o (elim_tac @{thms HOL.conjE} ctxt) + val aentails_hoist_pure_precise_assms_tac : Proof.context -> int -> tactic = fn ctxt => + (* Float all precise pure assumptions. *) + TRY o aentails_float_pure_precise_assms_tac ctxt + (* Hoist directly; zero ownership produces no closure condition. *) + THEN' intro_tac @{thms apure_precise_entailsL0 apure_precise_entailsL} ctxt + (* Split newly introduced pure premises. *) + THEN' TRY o (elim_tac @{thms HOL.conjE} ctxt) + val aentails_hoist_pure_concls_tac : Proof.context -> int -> tactic = fn ctxt => - ucincl_discharge_tac ctxt ( - (* float all pure conclusion *) + ucincl_must_discharge_tac ctxt ( + (* float all pure conclusions *) TRY o aentails_float_pure_concls_tac ctxt - (* hoist them out *) - THEN' intro_tac @{thms apure_entailsR} ctxt + (* The restricted rule requires the retained conclusion to absorb split resource. *) + THEN' intro_tac @{thms apure_entailsR_restricted} ctxt ) + val aentails_hoist_pure_precise_concls_tac : Proof.context -> int -> tactic = fn ctxt => + (* Float all precise pure conclusions. *) + TRY o aentails_float_pure_precise_concls_tac ctxt + (* Keep the pure premise spatial for later drule and rule branches. *) + THEN' intro_tac @{thms apure_precise_entailsR'} ctxt + val aentails_hoist_existential_assms_tac : Proof.context -> int -> tactic = fn ctxt => CHANGED o ( CONVERSION (aentails_conv'' (Conv.changed_conv o asepconj_hoist_existential_conv) (K Conv.all_conv) ctxt) THEN' REPEAT_ALL_NEW (resolve_tac ctxt @{thms aexists_entailsL}) ) - (* TODO: This is out of sync with the _method_ `aentails_simp_core` *) val aentails_simp_core_tac : Proof.context -> int -> tactic = fn ctxt => let fun NOTE msg = Fine_Grained_Timing.TIME' ctxt (Config.get ctxt Crush_Config.time_aentails_core) msg #> Crush_Tacticals.LOG' ctxt (Config.get ctxt Crush_Config.log_aentails_core) msg in ucincl_discharge_tac ctxt ( NOTE "aentails_core_hoist_pure_assms" (aentails_hoist_pure_assms_tac ctxt) + ORELSE' NOTE "aentails_core_hoist_pure_precise_assms" (aentails_hoist_pure_precise_assms_tac ctxt) ORELSE' NOTE "aentails_core_hoist_pure_concls" (aentails_hoist_pure_concls_tac ctxt) + ORELSE' NOTE "aentails_core_hoist_pure_precise_concls" (aentails_hoist_pure_precise_concls_tac ctxt) + ORELSE' NOTE "aentails_core_canonicalize_top" (aentails_canonicalize_top_tac ctxt) + ORELSE' NOTE "aentails_core_intro_concls" (aentails_simp_core_intro_concls_tac ctxt) ORELSE' NOTE "aentails_core_intro_others" (aentails_simp_core_intro_others_tac ctxt) ORELSE' NOTE "aentails_core_cancel_univ_prems" (aentails_simp_core_cancel_univ_prems ctxt) ORELSE' NOTE "aentails_core_hoist_existential_assms" (aentails_hoist_existential_assms_tac ctxt) @@ -2216,16 +2342,50 @@ struct fun is_cancellable_pair (ctxt : Proof.context) = let val allow_pure = Config.get ctxt Crush_Config.cancel_pure in fn (t0 : term) => fn (t1 : term) => - if (not allow_pure) andalso (is_pure t0 orelse is_pure t1) then + if (not allow_pure) andalso + (is_pure t0 orelse is_pure t1 orelse is_pure_precise t0 orelse is_pure_precise t1) then false else is_unifiable_pair ctxt t0 t1 end + (* Cancellation floats its selected pair first. Insert top immediately after the selected + right-hand factor, so its own upwards closure is sufficient and schematics in the remaining + right-hand conjunction are irrelevant. A schematic selected factor is still left alone: + asking closure search to shape it could choose a caller-owned witness. *) + fun wants_inserted_top (t : term) : bool = + let val (_, concls) = t |> unwrap_aentails + val concl_factors = split_asepconj concls + in + case concl_factors of + factor :: _ :: _ => + not (List.exists is_top concl_factors) + andalso not (Term.exists_subterm Term.is_Var factor) + | _ => false + end + handle SeparationLogic _ => false + + fun aentails_insert_top_tac ctxt = + let fun NOTE msg = Fine_Grained_Timing.TIME' ctxt (Config.get ctxt Crush_Config.time_insert_top) msg + #> Crush_Tacticals.LOG' ctxt (Config.get ctxt Crush_Config.log_insert_top) msg + in + Crush_Tacticals.IF' wants_inserted_top (NOTE "aentails_insert_top" ( + (* The insertion is available only when closure of the selected factor is proved. *) + ucincl_must_discharge_tac ctxt + (resolve_tac ctxt @{thms aentails_insert_top_after_ucincl}))) + end + fun aentails_cancel_core_tac ctxt = - (Fine_Grained_Timing.TIME' ctxt (Config.get ctxt Crush_Config.time_aentails_cancel) "aentails_cancel_tac_unify_and_float" - (aentails_float_match ctxt (is_cancellable_pair ctxt))) - THEN' (resolve_tac ctxt @{thms aentails_refl asepconj_mono asepconj_mono5 aentails_cancel_r}) + (Fine_Grained_Timing.TIME' ctxt (Config.get ctxt Crush_Config.time_aentails_cancel) + "aentails_cancel_tac_unify_and_float" + (aentails_float_match ctxt (is_cancellable_pair ctxt))) + THEN' (TRY o aentails_insert_top_tac ctxt) + THEN' ( + (* Prefer rules which account for every factor. *) + resolve_tac ctxt @{thms aentails_refl asepconj_mono asepconj_mono5} + (* Dropping unmatched assumptions requires an immediately discharged licence. *) + ORELSE' (resolve_tac ctxt @{thms aentails_cancel_r_discardable} + THEN_ALL_NEW discardable_in_tac ctxt)) val aentails_cancel_legacy_points_to : Proof.context -> int -> tactic = fn ctxt => if not (Config.get ctxt Crush_Config.enable_legacy_points_to_tactics) then @@ -2370,6 +2530,9 @@ local val _ = Theory.setup (Method.setup @{binding "aentails_hoist_pure_assms"} (Scan.succeed (SIMPLE_METHOD' o (Separation_Logic_Tactics.aentails_hoist_pure_assms_tac))) "") + val _ = Theory.setup (Method.setup @{binding "aentails_hoist_pure_precise_assms"} + (Scan.succeed (SIMPLE_METHOD' o (Separation_Logic_Tactics.aentails_hoist_pure_precise_assms_tac))) "") + val _ = Theory.setup (Method.setup @{binding "aentails_hoist_existential"} (Scan.succeed (SIMPLE_METHOD' o (Separation_Logic_Tactics.aentails_hoist_existential_assms_tac))) "hoist existentials out of the LHS of a separating entailment") @@ -2398,7 +2561,8 @@ local val _ = Theory.setup (Method.setup @{binding "ucincl_solve"} (Method.sections (Simplifier.simp_modifiers @ Splitter.split_modifiers) - |-- Scan.succeed (fn ctxt => SIMPLE_METHOD' (REPEAT_DETERM1 o (Separation_Logic_Tactics.ucincl_solve_tac ctxt)))) "") + |-- Scan.succeed (fn ctxt => SIMPLE_METHOD' + (SOLVED' (Separation_Logic_Tactics.ucincl_solve_tac ctxt)))) "") val _ = Theory.setup (Method.setup @{binding "ucincl_discharge"} (Method.sections Simplifier.simp_modifiers |-- Scan.lift (Parser.parse_method >> (fn m => fn (ctxt : Proof.context) => diff --git a/Micro_Rust_Examples/Crush_Examples.thy b/Micro_Rust_Examples/Crush_Examples.thy index 5674c677..8b66f458 100644 --- a/Micro_Rust_Examples/Crush_Examples.thy +++ b/Micro_Rust_Examples/Crush_Examples.thy @@ -320,6 +320,21 @@ begin by (crush_base simp prems add: Some_Ex_def seplog drule add: PQ) end +text\A destruction rule may produce a precise-pure factor. The entailment +core leaves its content as a separating entailment, so the spatial drule +branch remains applicable; \<^term>\ucincl Q\ licenses the discarded remainder.\ + +experiment + fixes P Q :: \'s::sepalg assert\ + and R :: bool + assumes PQ: \P \ Q \ \R\\ +begin + lemma + assumes \ucincl Q\ + shows \P \ \R\ \ Q\ + using assms by (crush_base seplog drule add: PQ) +end + subsubsection\Generic simplifications\ text\We have already seen that \<^verbatim>\crush\ applies simplification rules for separation logic @@ -351,13 +366,13 @@ experiment begin definition \Some_Ex \ \x. P x\ - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ by (crush_base simp prems add: Some_Ex_def seplog rule add: PQ) text\This example would already be rather tedious to prove by hand. Indeed, already the number of \<^verbatim>\crush\ steps has increased notably:\ - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ apply (crush_base_step simp prems add: Some_Ex_def seplog rule add: PQ) apply (crush_base_step simp prems add: Some_Ex_def seplog rule add: PQ) apply (crush_base_step simp prems add: Some_Ex_def seplog rule add: PQ) @@ -392,7 +407,7 @@ begin with \<^verbatim>\crush\.\ ucincl_auto Some_Ex - lemma \Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ \\ + lemma \Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ \\ \\This would not have worked without \<^verbatim>\no_schematics\ because \<^verbatim>\Some_Ex\ needs early unfolding. Alternatively to \<^verbatim>\simp prems add: ..\, we can also avoid introducing schematics for now, and this way ensure that \<^verbatim>\Some_Ex\ gets unfolded before schematics are introduced:\ @@ -401,6 +416,43 @@ begin done end +subsection\Support for separation logic constructs\ +subsubsection\Support for pure embeddings \<^term>\apure (P)\ and precise pure embeddings \<^term>\\P\\\ +experiment + fixes P Q :: bool + and R :: \'s::sepalg assert\ +begin +text\Ordinary pure conclusions can absorb \<^term>\R\ because they are +upwards-closed.\ +lemma + assumes P + shows \apure (Q) \ R \ apure (P) \ apure (Q)\ + using assms by crush_base + +text\Precise pure conclusions require \<^term>\R\ to own no resource.\ +lemma + assumes \R \ emp\ + shows \\Q \ P\ \ R \ \P\ \ \Q\\ + by crush_base (rule assms) +end + +subsubsection\Support for discardability \<^term>\discardable_in \ \\\ +experiment + fixes \ \ :: \'s::sepalg assert\ +begin +text\An upwards-closed retained assertion absorbs the resource of unmatched assumptions:\ +lemma + assumes \ucincl \\ + shows \\ \ \ \ \\ + using assms by crush_base + +text\An unmatched assertion entailing \<^term>\emp\ supplies a zero-ownership licence:\ +lemma + assumes \\ \ emp\ + shows \\ \ \ \ \\ + using assms by crush_base +end + subsection\Disabling case splits\ text\By default \<^verbatim>\crush\ uses \<^verbatim>\safe\ to split disjunctive premises, and to split conjunctive @@ -485,13 +537,13 @@ experiment begin definition \Some_Ex \ \x. P x\ - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ by (crush_base simp prems add: Some_Ex_def seplog rule add: PQ) text\This example would already be rather tedious to prove by hand. Indeed, already the number of \<^verbatim>\crush\ steps has increased notably:\ - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ apply (crush_base_step simp prems add: Some_Ex_def seplog rule add: PQ) apply (crush_base_step simp prems add: Some_Ex_def seplog rule add: PQ) apply (crush_base_step simp prems add: Some_Ex_def seplog rule add: PQ) @@ -519,23 +571,23 @@ experiment begin definition \Some_Ex \ \x. P x\ - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ by (crush_base simp prems add: Some_Ex_def seplog rule add: PQ) \\How many steps did we actually need?\ - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ apply (crush_base simp prems add: Some_Ex_def seplog rule add: PQ bigstep: false gas: 10) done \\10 was enough!\ - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ apply (crush_base simp prems add: Some_Ex_def seplog rule add: PQ bigstep: false gas: 5) oops \\5 not enough\ - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ apply (crush_base simp prems add: Some_Ex_def seplog rule add: PQ bigstep: false gas: 9) done \\9 was enough!\ - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ apply (crush_base simp prems add: Some_Ex_def seplog rule add: PQ bigstep: false gas: 8) oops \\8 not enough\ @@ -563,7 +615,7 @@ experiment begin definition \Some_Ex \ \x. P x\ - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ using [[crush_log_toplevel]] apply (crush_base simp prems add: Some_Ex_def seplog rule add: PQ stepwise) step to goal pattern "_ \ (\_. _)" @@ -572,14 +624,14 @@ begin step * done - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ using [[crush_log_toplevel]] apply (crush_base simp prems add: Some_Ex_def seplog rule add: PQ stepwise) step to premise pattern "R" step * done - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ using [[crush_log_toplevel]] apply (crush_base simp prems add: Some_Ex_def seplog rule add: PQ stepwise) step to schematic "x" 7 @@ -602,7 +654,7 @@ experiment begin definition \Some_Ex \ \x. P x\ - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ \\TODO: This should be configurable through the \<^verbatim>\crush\ command line\ apply (crush_base simp prems add: Some_Ex_def seplog rule add: PQ history) back back back back @@ -642,12 +694,12 @@ begin definition \Some_Ex \ \x. P x\ ucincl_auto Some_Ex - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ \\Stopping once the existential quantification on the right has reached the top-level\ apply (crush_base bigstep:false abort at pattern: "_ \ (\_. _)") oops - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ \\Stopping on the first non-separation logic goal\ apply (crush_base bigstep:false simp prems add: Some_Ex_def seplog rule add: PQ abort at filter: \ fn (ctxt : Proof.context) => fn (goal : term) => @@ -693,7 +745,7 @@ experiment begin definition \Some_Ex \ \x. P x\ - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ using [[crush_log_toplevel]] by (crush_base simp prems add: Some_Ex_def seplog rule add: PQ) (* crush_branch_aentails_cancel_tac success (0.000091s) @@ -706,7 +758,7 @@ begin crush_branch_aentails_cancel_tac success (0.000049s) *) \\The same, but now also showing all intermediate goals:\ - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ using [[crush_log_toplevel, crush_log_goal]] by (crush_base simp prems add: Some_Ex_def seplog rule add: PQ) end @@ -735,13 +787,13 @@ experiment begin definition \Some_Ex \ \x. P x\ - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ using [[crush_log_schematics]] apply (crush_base simp prems add: Some_Ex_def seplog rule add: PQ) oops \\Again, but this time implicit in \<^verbatim>\stepwise\, and giving a finer breakdown of steps:\ - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ apply (crush_base simp prems add: Some_Ex_def seplog rule add: PQ stepwise) step * oops @@ -812,7 +864,7 @@ experiment begin definition \Some_Ex \ \x. P x\ - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ \\By default, the timing mechanism ignores runtimes < 2ms, which is too high to observe the runtime of the tactics in this trivial example. We reduce the threshold to 5ns.\ using [[crush_time_toplevel, fine_grained_timing_threshold=5]] @@ -834,7 +886,7 @@ experiment begin definition \Some_Ex \ \x. P x\ - lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ \\Stop if \<^verbatim>\crush\ hits a branch that takes more than 1s\ using [[crush_time_steps, crush_time_step_bound_ms=1000]] apply (crush_base simp prems add: Some_Ex_def bigstep: false branch add: \sleep 2\) @@ -979,10 +1031,6 @@ lemma step step step - step - step - step - step done subsubsection\Function contracts and specifications\ @@ -1012,13 +1060,6 @@ definition swap_ref_fun_contract :: text\Note how we are force to make all contextual parameters of the function specification arguments to the function contract definition.\ -text\As with all assertions, we need to prove that pre and post conditions are upwards closed. -Luckily, there is custom automation to do this:\ -ucincl_auto swap_ref_fun_contract - -text\If the proof isn't trivial, you can use \<^verbatim>\ucincl_proof\ instead to open up a proof context -for the required \<^verbatim>\ucincl\ assertions.\ - text\Next, we state and prove the function specification:\ lemma swap_ref_fun_spec: @@ -1044,7 +1085,6 @@ definition rotate_ref3_contract :: let pre = rA \ \\\ gA\vA \ rB \\\\ gB\vB \ rC \\\\ gC\vC in let post = \_. (\gA' gB' gC'. rA \ \\\ gA'\vB \ rB \\\\ gB'\vC \ rC \\\\ gC'\vA) in make_function_contract pre post\ -ucincl_auto rotate_ref3_contract text\To prove the specification for \<^verbatim>\rotate_ref3\, we could just unfold/inline the definition of \<^verbatim>\swap_ref_fun\:\ @@ -1102,6 +1142,28 @@ no_adhoc_overloading store_update_const \ end +text\\<^verbatim>\crush_boot\ hoists precise-pure preconditions into HOL premises, which +\<^verbatim>\goal_cases\ exposes for Isar reasoning.\ + +definition bounded_id :: \nat \ ('s, nat, 'abort, 'i prompt, 'o prompt_output) function_body\ where + \bounded_id n \ FunctionBody (literal n)\ + +definition bounded_id_contract :: \nat \ ('s::sepalg, nat, 'abort) function_contract\ where + \bounded_id_contract n \ + let pre = \n < 20\ in + let post = \r. \r = n\ \ \n + 1 \ 20\ in + make_function_contract pre post\ + +lemma bounded_id_spec: + shows \\; bounded_id n \\<^sub>F bounded_id_contract n\ +proof (crush_boot f: bounded_id_def contract: bounded_id_contract_def, goal_cases) + case 1 + from 1 have \n + 1 \ 20\ + by simp + then show ?case + by crush_base +qed + subsubsection\Reasoning about references and structures\ text\The next examples demonstrate how \<^verbatim>\crush\ can reason about structure and array manipulation. @@ -1160,9 +1222,8 @@ definition write_foo_read_bar_contract :: \('a, 'b, test_record) Global_Store.ref \ 'b \ test_record \ ('s, int, 'abort) function_contract\ where \write_foo_read_bar_contract r g v \ let pre = r \ \\\ g\v in - let post = \t. \t = test_record.bar v\ \ (\g'. r \ \\\ g'\(test_record.update_foo (\_. 42) v)) in + let post = \t. apure (t = test_record.bar v) \ (\g'. r \ \\\ g'\(test_record.update_foo (\_. 42) v)) in make_function_contract pre post\ -ucincl_auto write_foo_read_bar_contract lemma write_foo_read_bar_spec: shows \\; write_foo_read_bar ptr \\<^sub>F write_foo_read_bar_contract ptr g v\ @@ -1224,7 +1285,6 @@ lemma write_foo_read_bar_spec': step step step - step done text\Clear many structure fields, return another:\ @@ -1318,7 +1378,7 @@ definition test_record2_zeroize_contract :: \('a, 'b, test_record2) Global_Store.ref \ 'b \ test_record2 \ ('s, int, 'abort) function_contract\ where \test_record2_zeroize_contract r g v \ let pre = r \ \\\ g\v in - let post = \t. \t = test_record2.f20 v\ \ (\g'. r \ \\\ g'\( + let post = \t. apure (t = test_record2.f20 v) \ (\g'. r \ \\\ g'\( test_record2.update_f0 (\_. 0) ( test_record2.update_f1 (\_. 0) ( test_record2.update_f2 (\_. 0) ( @@ -1342,7 +1402,6 @@ definition test_record2_zeroize_contract :: v )))))))))))))))))))))) in make_function_contract pre post\ -ucincl_auto test_record2_zeroize_contract lemma test_record2_zeroize_contract_spec: shows \\; test_record2_zeroize ptr \\<^sub>F test_record2_zeroize_contract ptr g v\ @@ -1366,7 +1425,6 @@ definition test_record3_zero_field_contract :: let zero_ith_pure :: test_record3 \ test_record3 = (\t. t \ data := array_update (data t) (unat i) 0 \ ) in let post = \_. r \ \\\ zero_ith_pure\(g\v) in make_function_contract pre post\ -ucincl_auto test_record3_zero_field_contract text\For many non-trivial examples it is useful to conduct some Isar-style reasoning prior to starting the \<^verbatim>\apply\-style \<^verbatim>\crush\ proof. The following proof demonstrates this pattern:\ @@ -1451,9 +1509,8 @@ definition test_record3_zeroize_contract :: where \test_record3_zeroize_contract r g v \ let pre = r \ \\\ g\v in let zero_data_pure :: test_record3 \ test_record3 = (\t. t \ data := array_constant 0 \ ) in - let post = \ret. \ret = rest v\ \ (\g'. r \ \\\ g'\(zero_data_pure v)) in + let post = \ret. apure (ret = rest v) \ (\g'. r \ \\\ g'\(zero_data_pure v)) in make_function_contract pre post\ -ucincl_auto test_record3_zeroize_contract lemma test_record3_zeroize_spec: \\TODO: This can go away once specs are eager by default\ @@ -1493,14 +1550,6 @@ proof (crush_boot f: test_record3_zeroize_def contract: test_record3_zeroize_con show ?case \\TODO: This proof gets slower over time. Investigate\ apply (crush_base stepwise) - step 100 - step 100 - step 100 - step 100 - step 100 - step 100 - step 100 - step 100 step * apply (simp add: eq) done diff --git a/Micro_Rust_Examples/Linked_List.thy b/Micro_Rust_Examples/Linked_List.thy index 4acb0960..0f63c999 100644 --- a/Micro_Rust_Examples/Linked_List.thy +++ b/Micro_Rust_Examples/Linked_List.thy @@ -89,11 +89,9 @@ fun ll_points_to :: \'t list \ \abstracted prefix o lemma ll_points_to_None: shows \ll_points_to ds None rem = \ds = []\ \ \rem = None\\ -by (cases ds; clarsimp simp add: asepconj_simp apure_def) +by (cases ds; clarsimp simp add: asepconj_simp HOL.eq_commute) -lemma ucincl_ll_points_to [ucincl_intros]: - shows \ucincl (ll_points_to ds ll rem)\ -by (induction ds; cases ll; auto intro: ucincl_intros) +\\The predicate owns exactly the represented list and is not upwards closed.\ definition reverse_unlink_contract :: \64 word @@ -115,8 +113,6 @@ definition reverse_unlink_contract :: \ \b = rem\ \\Tail of initial list\ \ ll_points_to (rev ts) a None \\Reversed head of initial list\ ) in make_function_contract pre post\ -ucincl_proof reverse_unlink_contract - by (auto split!: prod.splits intro: ucincl_intros) lemma reverse_unlink_spec [crush_specs]: shows \\; reverse_unlink n ll tmp0 tmp1 \\<^sub>F reverse_unlink_contract n ll tmp0 tmp1 ts rem\ @@ -124,12 +120,13 @@ lemma reverse_unlink_spec [crush_specs]: apply crush_base apply (ucincl_discharge\ rule_tac INV=\\_ i. + can_alloc_reference \ (\g_last g_cur v_last v_cur. tmp1\\\\ g_last\v_last \ tmp0\\\\ g_cur\v_cur \ ll_points_to (rev (take i ts)) v_last None \ ll_points_to (drop i ts) v_cur rem - )\ and \=\\_.\False\\ + )\ and \=\\_.apure (False)\ in wp_raw_for_loop_framedI'\) apply (fastcrush_base simp add: Many_More.drop_Suc_nth) apply (fastcrush_base split!: option.splits simp add: take_suc_rev') @@ -169,14 +166,12 @@ definition reverse_unlink'_contract :: \ ('caddr, 'gv) gref option \ ('s, ('caddr, 'gv) gref option \ ('caddr, 'gv) gref option \ tnil, 'abort) function_contract\ where \reverse_unlink'_contract n ll ts rem \ - let pre = can_alloc_reference \ ll_points_to ts ll rem \ \unat n = length ts\ in + let pre = can_alloc_reference \ ll_points_to ts ll rem \ apure (unat n = length ts) in let post = (\r. let (a,b,_) = r in can_alloc_reference - \ \b = rem\ \\Tail of initial list\ + \ apure (b = rem) \\Tail of initial list\ \ ll_points_to (rev ts) a None \\Reversed head of initial list\ ) in make_function_contract pre post\ -ucincl_proof reverse_unlink'_contract - by (auto split!: prod.splits intro: ucincl_intros) lemma reverse_unlink'_spec: shows \\; reverse_unlink' n ll \\<^sub>F reverse_unlink'_contract n ll ts rem\ diff --git a/Micro_Rust_Examples/MLKEM_NTT.thy b/Micro_Rust_Examples/MLKEM_NTT.thy index e0a3ce9e..60cb717f 100644 --- a/Micro_Rust_Examples/MLKEM_NTT.thy +++ b/Micro_Rust_Examples/MLKEM_NTT.thy @@ -187,13 +187,12 @@ definition ntt_contract :: ('s::{sepalg}, unit, 'b) function_contract\ where [crush_contracts]: \ntt_contract f_ref g p \ let pre = f_ref \\\\ g\p \ - \poly_wf p\ \ + apure (poly_wf p) \ can_alloc_reference; post = \_. (\ g'. f_ref \\\\ g'\(MLKEM_Specification.ntt p)) \ - \poly_wf (MLKEM_Specification.ntt p)\ \ + apure (poly_wf (MLKEM_Specification.ntt p)) \ can_alloc_reference in make_function_contract pre post\ -ucincl_auto ntt_contract text\The NTT proof is the most involved verification in this development. It requires three nested loop invariants, each using the ``backwards'' approach: @@ -433,7 +432,6 @@ proof - qed lemma ntt_spec: - notes points_to_aentails_crule_focusedL[crush_aentails_cond_crules] shows \\; ntt f_ref \\<^sub>F ntt_contract f_ref g p\ proof (crush_boot f: ntt_def contract: ntt_contract_def, goal_cases) case 1 @@ -455,10 +453,13 @@ proof (crush_boot f: ntt_def contract: ntt_contract_def, goal_cases) = MLKEM_Specification.ntt_outer_loop 1 7 p\ \ \poly_wf p_cur\ \ \k_val \ 2 ^ layer\\ - and \=\\_. \False\\ and \=\\_. \False\\ + and \=\\_. apure (False)\ and \=\\_. apure (False)\ in wp_raw_for_loop_framedI'\) subgoal \ \Init/frame: establish INV[0] and frame INV[7] to postcondition\ apply (crush_base simp add: MLKEM_Specification.ntt_def) + \\The functional equality determines the schematic \<^term>\k_val\ witness before + automation handles the remaining goals.\ + apply (all \(rule refl)?\) apply auto done subgoal for layer \ \Outer loop step: one NTT layer\ @@ -474,8 +475,8 @@ proof (crush_boot f: ntt_def contract: ntt_contract_def, goal_cases) (2 ^ (7 - layer)) (2 ^ layer) (2 ^ layer) p_cur\ \ \poly_wf p_mid\ \ \k_val + 2 ^ layer \ 128\\ - and \=\\_. \False\\ - and \=\\_. \False\\ + and \=\\_. apure (False)\ + and \=\\_. apure (False)\ in wp_raw_for_loop_framedI'\) subgoal \ \middle init/frame\ apply (crush_base no_schematics @@ -514,7 +515,7 @@ proof (crush_boot f: ntt_def contract: ntt_contract_def, goal_cases) (2 ^ (7 - layer)) j_off p_mid)\\ - and \=\\_. \False\\ and \=\\_. \False\\ + and \=\\_. apure (False)\ and \=\\_. apure (False)\ in wp_raw_for_loop_framedI'\) subgoal \ \inner init/frame\ apply (crush_base simp add: simp add: ntt_inner_len_val unat_of_nat_eq unat_power_lower) diff --git a/Micro_Rust_Examples/MLKEM_Polynomial.thy b/Micro_Rust_Examples/MLKEM_Polynomial.thy index ab94e511..7440838e 100644 --- a/Micro_Rust_Examples/MLKEM_Polynomial.thy +++ b/Micro_Rust_Examples/MLKEM_Polynomial.thy @@ -85,7 +85,6 @@ definition poly_add_contract :: \mlkem_poly \ mlkem_poly \r = MLKEM_Specification.poly_add a b\ \ \poly_wf r\ in make_function_contract pre post\ -ucincl_auto poly_add_contract lemma poly_add_spec [crush_specs]: shows \\; poly_add a b \\<^sub>F poly_add_contract a b\ @@ -96,8 +95,8 @@ lemma poly_add_spec [crush_specs]: rule_tac INV=\\_ i. \ g. result_ref \\\\ g\(array_splice i (MLKEM_Specification.poly_add a b) a)\ - and \=\\_. \False\\ - and \=\\_. \False\\ + and \=\\_. apure (False)\ + and \=\\_. apure (False)\ in wp_raw_for_loop_framedI'\) using poly_add_splice_step poly_add_splice_full MLKEM_Specification.poly_add_wf apply (crush_base @@ -138,7 +137,6 @@ definition poly_sub_contract :: \mlkem_poly \ mlkem_poly \r = MLKEM_Specification.poly_sub a b\ \ \poly_wf r\ in make_function_contract pre post\ -ucincl_auto poly_sub_contract lemma poly_sub_spec [crush_specs]: shows \\; poly_sub a b \\<^sub>F poly_sub_contract a b\ @@ -149,8 +147,8 @@ lemma poly_sub_spec [crush_specs]: rule_tac INV=\\_ i. \ g. result_ref \\\\ g\(array_splice i (MLKEM_Specification.poly_sub a b) a)\ - and \=\\_. \False\\ - and \=\\_. \False\\ + and \=\\_. apure (False)\ + and \=\\_. apure (False)\ in wp_raw_for_loop_framedI'\) using poly_sub_splice_step poly_sub_splice_full MLKEM_Specification.poly_sub_wf apply (crush_base diff --git a/Micro_Rust_Examples/MLKEM_Zq.thy b/Micro_Rust_Examples/MLKEM_Zq.thy index 6318ef3e..694adac9 100644 --- a/Micro_Rust_Examples/MLKEM_Zq.thy +++ b/Micro_Rust_Examples/MLKEM_Zq.thy @@ -92,7 +92,6 @@ definition zq_add_contract :: \16 word \ 16 word \ post = \r. \r = MLKEM_Specification.zq_add a b\ \ \unat r < mlkem_q\ in make_function_contract pre post\ -ucincl_auto zq_add_contract lemma zq_add_spec [crush_specs]: shows \\; zq_add a b \\<^sub>F zq_add_contract a b\ @@ -119,7 +118,6 @@ definition zq_sub_contract :: \16 word \ 16 word \ post = \r. \r = MLKEM_Specification.zq_sub a b\ \ \unat r < mlkem_q\ in make_function_contract pre post\ -ucincl_auto zq_sub_contract lemma zq_sub_spec [crush_specs]: shows \\; zq_sub a b \\<^sub>F zq_sub_contract a b\ @@ -155,7 +153,6 @@ definition zq_mul_contract :: \16 word \ 16 word \ post = \r. \r = MLKEM_Specification.zq_mul a b\ \ \unat r < mlkem_q\ in make_function_contract pre post\ -ucincl_auto zq_mul_contract lemma zq_mul_spec [crush_specs]: shows \\; zq_mul a b \\<^sub>F zq_mul_contract a b\ diff --git a/Micro_Rust_Examples/Showcase.thy b/Micro_Rust_Examples/Showcase.thy index 9eddfc77..c8872809 100644 --- a/Micro_Rust_Examples/Showcase.thy +++ b/Micro_Rust_Examples/Showcase.thy @@ -56,14 +56,12 @@ it should always return \<^term>\12 :: nat\. However, executing thi the allocation of local mutables. Owning the \<^term>\can_alloc_reference\ resource makes sure that we have the capability to do this. Note also the embedding of a pure fact \<^verbatim>\r = 12\ into separation logic via the -\<^verbatim>\\_\\ antiquotation.\ +\<^verbatim>\apure (_)\ antiquotation.\ definition ref_test_contract where \ref_test_contract \ let pre = can_alloc_reference in - let post = \r. can_alloc_reference \ \r = 12\ in + let post = \r. can_alloc_reference \ apure (r = 12) in make_function_contract pre post\ -text\The \<^verbatim>\ucincl_auto\ command is necessary boilerplate for every contract, ignore for now.\ -ucincl_auto ref_test_contract text\Now we prove that the function satisfies the contract!\ lemma ref_test_spec: @@ -101,7 +99,6 @@ definition swap_ref_contract :: \('addr, 'gv, 'v) Global_Store.ref \\\\ (\_. rval) \ (lg\lval) \ rref \\\\ (\_. lval) \ (rg\rval) in make_function_contract pre post\ -ucincl_auto swap_ref_contract text\Proving this specification is as straightforward as before\ lemma swap_ref_spec: @@ -123,9 +120,8 @@ text\After swapping, the variable left should now contain the value \<^ter definition swap_client_contract where \swap_client_contract \ let pre = can_alloc_reference in - let post = \ r. \r = (72 :: nat)\ \ can_alloc_reference in + let post = \ r. apure (r = (72 :: nat)) \ can_alloc_reference in make_function_contract pre post\ -ucincl_auto swap_client_contract text\We can verify this in two ways. Firstly, we can tell the automation to use the verified specification of \<^term>\swap_ref\, using the \<^verbatim>\specs add:\ and \<^verbatim>\contracts add:\ modifiers\ @@ -169,11 +165,10 @@ text\The contract for \<^term>\sum_array\: the stateful imple as the functional implementation that uses \<^term>\sum_list\\ definition sum_array_contract :: \(nat, 'a::len) array \ 64 word \ ('s, nat, 'b) function_contract\ where \sum_array_contract nums l \ - let pre = can_alloc_reference \ \unat l = LENGTH('a)\ in + let pre = can_alloc_reference \ apure (unat l = LENGTH('a)) in let post = \ r. - \r = sum_list (array_to_list nums)\ \ can_alloc_reference in + apure (r = sum_list (array_to_list nums)) \ can_alloc_reference in make_function_contract pre post\ -ucincl_auto sum_array_contract text\The proof of the specification is a bit more involved, since we need to deal with the loop\ lemma sum_spec: @@ -197,13 +192,13 @@ so that we can reference it in the loop invariant.\ \ \Now, apply the rule for proving for-loops. The \<^verbatim>\INV=\\ _ i. \\\ states the loop-invariant that we will use in the proof to verify our specification. The \<^verbatim>\\=\\ and \<^verbatim>\\=\\ refer to conditions for raising exceptions or returning early while inside the loop body. Making these -equal to \<^term>\\_. \False\\ ensures that raising an exception or returning early is illegal, +equal to \<^term>\\_. apure (False)\ ensures that raising an exception or returning early is illegal, like we would expect.\ apply (ucincl_discharge\ rule_tac INV=\\_ i. \ g. sum_ref \\\\ g\(sum_list (take i (array_to_list nums)))\ and - \=\\_. \False\\ and - \=\\_. \False\\ + \=\\_. apure (False)\ and + \=\\_. apure (False)\ in wp_raw_for_loop_framedI' \) \ \We are left with two subgoals: diff --git a/Micro_Rust_Examples/Tutorial.thy b/Micro_Rust_Examples/Tutorial.thy index 4fcfc69a..f5e3b112 100644 --- a/Micro_Rust_Examples/Tutorial.thy +++ b/Micro_Rust_Examples/Tutorial.thy @@ -71,10 +71,9 @@ definition clamp :: \nat \ nat \ nat \ definition clamp_contract where \clamp_contract lo hi x \ - let pre = \lo \ hi\ in - let post = \r. \r \ lo \ r \ hi\ in + let pre = apure (lo \ hi) in + let post = \r. apure (r \ lo \ r \ hi) in make_function_contract pre post\ -ucincl_auto clamp_contract text\TODO: Replace \<^verbatim>\oops\ with a proof. Hint: \<^verbatim>\apply (crush_boot f:clamp_def contract: clamp_contract_def)\ sets up the goal @@ -104,10 +103,9 @@ value \max (0::nat) (1::nat)\ definition max_of_contract where \max_of_contract a b \ - let pre = \True\ in - let post = \r. \True\ in + let pre = apure (True) in + let post = \r. apure (True) in make_function_contract pre post\ -ucincl_auto max_of_contract text\TODO: Prove the specification once your contract is correct.\ lemma max_of_spec: @@ -154,10 +152,9 @@ definition abs_diff :: \nat \ nat \ ('s, nat, 'abo text\TODO: Write the contract\ definition abs_diff_contract where \abs_diff_contract a b \ - let pre = \True\ in - let post = \r. \True\ in + let pre = apure (True) in + let post = \r. apure (True) in make_function_contract pre post\ -ucincl_auto abs_diff_contract text\TODO: Prove the specification.\ lemma abs_diff_spec: @@ -180,10 +177,9 @@ definition double :: \nat \ ('s, nat, 'abort, 'i prompt, 'o pr definition double_contract where \double_contract n \ - let pre = \True\ in - let post = \r. \r = 2 * n\ in + let pre = apure (True) in + let post = \r. apure (r = 2 * n) in make_function_contract pre post\ -ucincl_auto double_contract lemma double_spec: shows \\; double n \\<^sub>F double_contract n\ @@ -200,10 +196,9 @@ definition quadruple :: \nat \ ('s, nat, 'abort, 'i prompt, 'o text\TODO: Write the contract for \<^term>\quadruple\.\ definition quadruple_contract where \quadruple_contract n \ - let pre = \True\ in - let post = \r. \True\ in + let pre = apure (True) in + let post = \r. apure (True) in make_function_contract pre post\ -ucincl_auto quadruple_contract text\TODO: Prove the specification using \<^term>\double_spec\. Hint: use \<^verbatim>\specs add: double_spec\ and \<^verbatim>\contracts add: double_contract_def\ @@ -231,10 +226,9 @@ definition bvec_is_empty :: \('a, 'l::len) bounded_vec \ ('s, text\TODO: Write the contract\ definition bvec_is_empty_contract :: \('a, 'l::len) bounded_vec \ ('s::sepalg, bool, 'b) function_contract\ where \bvec_is_empty_contract v \ - let pre = \True\ in - let post = \r. \True\ in + let pre = apure (True) in + let post = \r. apure (True) in make_function_contract pre post\ -ucincl_auto bvec_is_empty_contract text\This lemma may be useful. TODO: Complete the proof\ lemma bvec_is_empty: @@ -266,10 +260,9 @@ Hints: \<^item> Postcondition: the result is \<^verbatim>\Some (bvec_abs v ! unat idx)\.\ definition bvec_get_contract :: \('a, 'l::len) bounded_vec \ 64 word \ ('s::sepalg, 'a option, 'b) function_contract\ where \bvec_get_contract v idx \ - let pre = \True\ in - let post = \r. \True\ in + let pre = apure (True) in + let post = \r. apure (True) in make_function_contract pre post\ -ucincl_auto bvec_get_contract text\TODO: Prove the specification.\ thm WordAdditional.lt_word_to_natI @@ -297,10 +290,9 @@ definition bvec_contains :: \(nat, 'l::len) bounded_vec \ nat definition bvec_contains_contract :: \(nat, 'l::len) bounded_vec \ nat \ ('s::sepalg, bool, 'b) function_contract\ where \bvec_contains_contract v needle \ - let pre = can_alloc_reference \ \bvec_well_formed v\ \ \unat (bvec_len v) = LENGTH('l)\ in - let post = \r. can_alloc_reference \ \bvec_well_formed v\ \ \r \ needle \ set (bvec_abs v)\ in + let pre = can_alloc_reference \ apure (bvec_well_formed v) \ apure (unat (bvec_len v) = LENGTH('l)) in + let post = \r. can_alloc_reference \ apure (bvec_well_formed v) \ apure (r \ needle \ set (bvec_abs v)) in make_function_contract pre post\ -ucincl_auto bvec_contains_contract text\TODO: Write the loop invariant Hints: @@ -334,7 +326,7 @@ text\So far, the bounded vector was passed by value. In this exercise, we The contract now uses \<^emph>\points-to\ predicates: \<^verbatim>\ptr \\\\ g\v\ says that \<^term>\ptr\ currently points to value \<^term>\v\. After mutation, we existentially quantify over the -new state: \<^verbatim>\\g' v'. ptr \\\\ g'\v' \ \...\\. +new state: \<^verbatim>\\g' v'. ptr \\\\ g'\v' \ apure (...)\. This function clears the vector by setting its length to zero.\ @@ -345,16 +337,15 @@ definition bvec_clear :: \('addr, 'gv, (nat, 'l::len) bounded_vec) ref \TODO: Write the contract and prove the specification. Hints: -\<^item> Precondition: \<^verbatim>\ptr \\\\ g\v \ \bvec_well_formed v\\ +\<^item> Precondition: \<^verbatim>\ptr \\\\ g\v \ apure (bvec_well_formed v)\ \<^item> Postcondition: the pointer still exists, the new value is well-formed and its - abstract list is empty. Use \<^verbatim>\\g' v'. ptr \\\\ g'\v' \ \...\\. + abstract list is empty. Use \<^verbatim>\\g' v'. ptr \\\\ g'\v' \ apure (...)\. \<^item> For the proof, add \<^verbatim>\micro_rust_record_simps\ to the simp set.\ definition bvec_clear_contract :: \(('addr, 'gv) gref, 'gv, (nat, 'l::len) bounded_vec) focused \ 'gv \ (nat, 'l) bounded_vec \ ('s::sepalg, unit, 'abort) function_contract\ where \bvec_clear_contract ptr g v \ - let pre = \True\ in - let post = \_. \True\ in + let pre = apure (True) in + let post = \_. apure (True) in make_function_contract pre post\ -ucincl_auto bvec_clear_contract lemma bvec_clear_spec: shows \\; bvec_clear ptr \\<^sub>F bvec_clear_contract ptr g v\ @@ -386,10 +377,10 @@ definition bvec_push :: \('addr, 'gv, (nat, 'l::len) bounded_vec) ref \TODO: Write the contract and prove the specification. Hints: -\<^item> Precondition: \<^verbatim>\ptr \\\\ g\v \ \unat (bvec_len v) \ LENGTH('l)\ \ \LENGTH('l) < 2 ^ LENGTH(64)\\ +\<^item> Precondition: \<^verbatim>\ptr \\\\ g\v \ apure (unat (bvec_len v) \ LENGTH('l)) \ apure (LENGTH('l) < 2 ^ LENGTH(64))\ \<^item> Ok postcondition: assert capacity wasn't full, and existentially quantify over the new global value, stating the pointer now holds the updated record: - @{verbatim \\unat (bvec_len v) < LENGTH('l)\ \ + @{verbatim \apure (unat (bvec_len v) < LENGTH('l)) \ (\g'. ptr \\\\ g'\(make_bounded_vec (bvec_len v + 1) (array_update (bvec_values v) (unat (bvec_len v)) (Some elem))))\} \<^item> Err postcondition: capacity was full, error carries the element back, pointer unchanged. @@ -397,10 +388,9 @@ Hints: followed by \<^verbatim>\cases v; simp add: nth_focus_array_components micro_rust_record_simps\.\ definition bvec_push_contract :: \(('addr, 'gv) gref, 'gv, (nat, 'l::len) bounded_vec) focused \ 'gv \ (nat, 'l) bounded_vec \ nat \ ('s::sepalg, (unit, nat) result, 'abort) function_contract\ where \bvec_push_contract ptr g v elem \ - let pre = \True\ in - let post = \_. \True\ in + let pre = apure (True) in + let post = \_. apure (True) in make_function_contract pre post\ -ucincl_auto bvec_push_contract lemma bvec_push_spec: shows \\; bvec_push ptr elem \\<^sub>F bvec_push_contract ptr g v elem\ @@ -428,10 +418,9 @@ lemma clamp_spec_solution: paragraph\Exercise 2\ definition max_of_contract_solution where \max_of_contract_solution a b \ - let pre = \True\ in - let post = \r. \r = max a b\ in + let pre = apure (True) in + let post = \r. apure (r = max a b) in make_function_contract pre post\ -ucincl_auto max_of_contract_solution lemma max_of_spec_solution: shows \\; max_of a b \\<^sub>F max_of_contract_solution a b\ @@ -453,9 +442,8 @@ paragraph\Exercise 3\ definition abs_diff_contract_solution where \abs_diff_contract_solution a b \ let pre = can_alloc_reference in - let post = \r. can_alloc_reference \ \r = (max a b) - (min a b)\ in + let post = \r. can_alloc_reference \ apure (r = (max a b) - (min a b)) in make_function_contract pre post\ -ucincl_auto abs_diff_contract_solution lemma abs_diff_spec_solution: shows \\; abs_diff a b \\<^sub>F abs_diff_contract_solution a b\ @@ -471,10 +459,9 @@ definition quadruple_solution :: \nat \ ('s, nat, 'abort, 'i p definition quadruple_contract_solution where \quadruple_contract_solution n \ - let pre = \True\ in - let post = \r. \r = 4 * n\ in + let pre = apure (True) in + let post = \r. apure (r = 4 * n) in make_function_contract pre post\ -ucincl_auto quadruple_contract_solution lemma quadruple_spec_solution: shows \\; quadruple_solution n \\<^sub>F quadruple_contract_solution n\ @@ -485,10 +472,9 @@ lemma quadruple_spec_solution: paragraph\Exercise 5\ definition bvec_is_empty_contract_solution :: \('a, 'l::len) bounded_vec \ ('s::sepalg, bool, 'b) function_contract\ where \bvec_is_empty_contract_solution v \ - let pre = \bvec_well_formed v\ in - let post = \r. \bvec_well_formed v \ (r \ bvec_abs v = [])\ in + let pre = apure (bvec_well_formed v) in + let post = \r. apure (bvec_well_formed v \ (r \ bvec_abs v = [])) in make_function_contract pre post\ -ucincl_auto bvec_is_empty_contract_solution lemma bvec_is_empty_solution: assumes \bvec_well_formed v\ @@ -504,10 +490,9 @@ lemma bvec_is_empty_spec_solution: paragraph\Exercise 6\ definition bvec_get_contract_solution :: \('a, 'l::len) bounded_vec \ 64 word \ ('s::sepalg, 'a option, 'b) function_contract\ where \bvec_get_contract_solution v idx \ - let pre = \bvec_well_formed v\ \ \unat idx < unat (bvec_len v)\ in - let post = \r. \bvec_well_formed v\ \ \r = Some (bvec_abs v ! unat idx)\ in + let pre = apure (bvec_well_formed v) \ apure (unat idx < unat (bvec_len v)) in + let post = \r. apure (bvec_well_formed v) \ apure (r = Some (bvec_abs v ! unat idx)) in make_function_contract pre post\ -ucincl_auto bvec_get_contract_solution lemma bvec_get_spec_solution: shows \\; bvec_get v idx \\<^sub>F bvec_get_contract_solution v idx\ @@ -542,10 +527,9 @@ qed paragraph\Exercise 8\ definition bvec_clear_contract_solution :: \(('addr, 'gv) gref, 'gv, (nat, 'l::len) bounded_vec) focused \ 'gv \ (nat, 'l) bounded_vec \ ('s::sepalg, unit, 'abort) function_contract\ where \bvec_clear_contract_solution ptr g v \ - let pre = ptr \\\\ g\v \ \bvec_well_formed v\ in - let post = \_. \g' v'. ptr \\\\ g'\v' \ \bvec_well_formed v' \ bvec_abs v' = []\ in + let pre = ptr \\\\ g\v \ apure (bvec_well_formed v) in + let post = \_. \g' v'. ptr \\\\ g'\v' \ apure (bvec_well_formed v' \ bvec_abs v' = []) in make_function_contract pre post\ -ucincl_auto bvec_clear_contract_solution lemma bvec_clear_spec_solution: shows \\; bvec_clear ptr \\<^sub>F bvec_clear_contract_solution ptr g v\ @@ -557,16 +541,14 @@ paragraph\Exercise 9\ definition bvec_push_contract_solution :: \(('addr, 'gv) gref, 'gv, (nat, 'l::len) bounded_vec) focused \ 'gv \ (nat, 'l) bounded_vec \ nat \ ('s::sepalg, (unit, nat) result, 'abort) function_contract\ where \bvec_push_contract_solution ptr g v elem \ let pre = ptr \\\\ g\v \ - \unat (bvec_len v) \ LENGTH('l)\ \ \LENGTH('l) < 2 ^ LENGTH(64)\ in + apure (unat (bvec_len v) \ LENGTH('l)) \ apure (LENGTH('l) < 2 ^ LENGTH(64)) in let post = \r. case r of - Ok _ \ \unat (bvec_len v) < LENGTH('l)\ \ + Ok _ \ apure (unat (bvec_len v) < LENGTH('l)) \ (\g'. ptr \\\\ g'\(make_bounded_vec (bvec_len v + 1) (array_update (bvec_values v) (unat (bvec_len v)) (Some elem)))) - | Err e \ \unat (bvec_len v) = LENGTH('l)\ \ \e = elem\ \ + | Err e \ apure (unat (bvec_len v) = LENGTH('l)) \ apure (e = elem) \ ptr \\\\ g\v in make_function_contract pre post\ -ucincl_proof bvec_push_contract_solution - by (auto split!: result.splits intro: ucincl_intros) lemma bvec_push_spec_solution: shows \\; bvec_push ptr elem \\<^sub>F bvec_push_contract_solution ptr g v elem\ diff --git a/Micro_Rust_Interfaces/Global_Perm_Store.thy b/Micro_Rust_Interfaces/Global_Perm_Store.thy index 3bc99652..4d9c0ace 100644 --- a/Micro_Rust_Interfaces/Global_Perm_Store.thy +++ b/Micro_Rust_Interfaces/Global_Perm_Store.thy @@ -104,10 +104,8 @@ proof (rule aentailsI) by auto moreover from calculation have \v1 = v2\ by (metis disjoint_sym option.inject sepalg_comm store_add_read) - moreover from calculation have \ucincl (points_to_raw' r (sh1 + sh2) v1)\ - using ucincl_points_to_raw'I by blast ultimately show \x \ r \ \sh1 + sh2\ v1 \ \v1 = v2\\ - by (simp add: asat_apure_distrib2) + by (simp add: asat_apure_precise_distrib2) qed lemma points_to_raw_split1: @@ -274,8 +272,8 @@ next qed lemma asat_hoist_pure: - shows \\ \ \P\ \ \ \ (P \ (\ \ \ \ \))\ (is ?g1) - and \\ \ \ \ \P\ \ (P \ (\ \ \ \ \))\ (is ?g2) + shows \\ \ apure P \ \ \ (P \ (\ \ \ \ \))\ (is ?g1) + and \\ \ \ \ apure P \ (P \ (\ \ \ \ \))\ (is ?g2) proof - show ?g1 by (simp add: apure_def asepconj_bot_zero) @@ -362,7 +360,7 @@ lemma striple_dereference_raw: shows \\; r \\sh\ v \ store.dereference_by_value_raw r \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\v'. r\\sh\ v \ \v = v'\) \ \ \ \\ apply (intro striple_localI) using urust_eval_predicate_dereference_raw_local - apply (auto simp: urust_eval_predicate_dereference_raw asat_hoist_pure ucincl_intros + apply (auto simp: urust_eval_predicate_dereference_raw asat_apure_precise_distrib2 simp add: asepconj_simp) done @@ -375,15 +373,27 @@ by (intro sstriple_from_stripleI, intro striple_dereference_raw) (auto simp add: lemma wp_dereference_raw: notes asat_simp [simp] and aentails_intro [intro] - assumes \\v. ucincl (\ v)\ shows \r\\sh\ g \ (r\\sh\ g \ \ g) \ \\

\ (store.dereference_by_value_raw r) \ \ \\ proof - - from assms have \r \\sh\ g \ (\g'. (r \\sh\ g \ \g = g'\) \ \ g') \ + have \r \\sh\ g \ (\g'. (r \\sh\ g \ \g = g'\) \ \ g') \ \\

\ (store.dereference_by_value_raw r) \ \ \\ by (intro sstriple_straightline_to_wp sstriple_dereference_raw) - moreover have \r \\sh\ g \ (r \\sh\ g \ \ g) \ r \\sh\ g \ (\g'. (r \\sh\ g \ \g = g'\) \ \ g')\ - by (auto elim!: asepconjE awandE intro!: asepconjI awandI simp add: - asat_weaken ucincl_points_to_raw'I aentails_def) + moreover have \r \\sh\ g \ (r \\sh\ g \ \ g) \ + r \\sh\ g \ (\g'. (r \\sh\ g \ \g = g'\) \ \ g')\ + proof (intro asepconj_mono4 aentails_refl aforall_entailsR) + fix g' + show \r \\sh\ g \ \ g \ (r \\sh\ g \ \g = g'\) \ \ g'\ + proof (cases \g = g'\) + \\A precise-pure factor is a unit when true and an annihilator when false.\ + case True + then show ?thesis + by (simp add: asepconj_simp aentails_refl) + next + case False + then show ?thesis + by (simp add: asepconj_simp awand_bot aentails_true) + qed + qed ultimately show ?thesis by blast qed @@ -409,7 +419,7 @@ proof - using sstriple_dereference_raw wp_sstriple_iff by blast then show ?thesis by (simp add: store.dereference_by_value_raw_fun_def satisfies_function_contract_def dereference_by_value_raw_contract'_def - ucincl_intros wp_sstriple_iff) + wp_sstriple_iff) qed subsection\Modifications behind a reference\ @@ -597,9 +607,6 @@ next using ref_raw_spec' by (simp add: reference_defs.reference_raw_contract_def reference_defs.points_to_raw_def reference_raw_contract'_def ucincl_can_alloc_referenceI asepconj_simp) -next - show \\r sh g. ucincl (reference_defs.points_to_raw points_to_raw' r sh g)\ - by (simp add: ucincl_points_to_raw'I reference_defs.points_to_raw_def) next show \ucincl can_alloc_reference\ by (simp add: ucincl_can_alloc_referenceI) diff --git a/Micro_Rust_Interfaces/Pair_References.thy b/Micro_Rust_Interfaces/Pair_References.thy index 36512143..45da5a3f 100644 --- a/Micro_Rust_Interfaces/Pair_References.thy +++ b/Micro_Rust_Interfaces/Pair_References.thy @@ -101,13 +101,11 @@ definition points_to_raw' :: \('a0 + 'a1, 'b0 + 'b1) gref \ sh (Inl r0, Inl b0) \ points_to_raw'A r0 sh b0 | (Inr r1, Inr b1) \ points_to_raw'B r1 sh b1 | _ \ {}\ -ucincl_proof points_to_raw' - using refA.ucincl_points_to_raw[unfolded reference_defs.points_to_raw_def] - refB.ucincl_points_to_raw[unfolded reference_defs.points_to_raw_def] - by (case_tac \plus_gref r\; case_tac b; auto simp add: ucincl_intros) definition can_alloc_reference :: \'s set\ where \can_alloc_reference \ can_alloc_referenceA\ +\\The \<^verbatim>\reference\ locale requires allocator availability to be upwards +closed; the registered fact discharges that interpretation obligation below.\ ucincl_auto can_alloc_reference definition gref_can_store :: \('a0 + 'a1, 'b0 + 'b1) gref \ ('b0 + 'b1) set\ where @@ -119,34 +117,9 @@ definition gref_can_store :: \('a0 + 'a1, 'b0 + 'b1) gref \ (' definition new_gref_can_store :: \('b0 + 'b1) set\ where \new_gref_can_store \ Inl ` new_gref_can_storeA\ -lemma [ucincl_intros]: - shows \ucincl (function_contract_pre ( - reference_defs.update_raw_contract points_to_raw' gref_can_store a b c))\ - and \ucincl (function_contract_post ( - reference_defs.update_raw_contract points_to_raw' gref_can_store a b c) r)\ - and \ucincl (function_contract_abort ( - reference_defs.update_raw_contract points_to_raw' gref_can_store a b c) ab)\ - and \ucincl (function_contract_pre ( - reference_defs.dereference_raw_contract points_to_raw' x y z))\ - and \ucincl (function_contract_post ( - reference_defs.dereference_raw_contract points_to_raw' x y z) r')\ - and \ucincl (function_contract_abort ( - reference_defs.dereference_raw_contract points_to_raw' x y z) ab)\ - and \ucincl (function_contract_pre ( - reference_defs.reference_raw_contract points_to_raw' gref_can_store new_gref_can_store can_alloc_reference g))\ - and \ucincl (function_contract_post ( - reference_defs.reference_raw_contract points_to_raw' gref_can_store new_gref_can_store can_alloc_reference g) r'')\ - and \ucincl (function_contract_abort ( - reference_defs.reference_raw_contract points_to_raw' gref_can_store new_gref_can_store can_alloc_reference g) ab)\ - by (auto intro!: ucincl_intros simp: reference_defs.update_raw_contract_def - reference_defs.reference_raw_contract_def - reference_defs.dereference_raw_contract_def reference_defs.points_to_raw_def) - lemma function_contract_empty: - assumes \\r. ucincl (\ r)\ shows \\ ; f \\<^sub>F make_function_contract {} \\ - using assms by (intro satisfies_function_contractI; clarsimp simp add: ucincl_intros - bot_aentails_all wp_to_sstriple) + by (intro satisfies_function_contractI; clarsimp simp add: bot_aentails_all wp_to_sstriple) lemma update_raw_fun_spec: \\ ; update_raw_fun r g \\<^sub>F @@ -154,7 +127,7 @@ lemma update_raw_fun_spec: using refA.update_raw_spec refB.update_raw_spec by (cases \plus_gref r\; cases g; cases g0; clarsimp simp add: update_raw_fun_def points_to_raw'_def gref_can_store_def reference_defs.update_raw_contract_def - reference_defs.points_to_raw_def Inl_Inr_image_in asepconj_False_True ucincl_intros + reference_defs.points_to_raw_def Inl_Inr_image_in asepconj_simp intro!: function_contract_empty) lemma dereference_raw_fun_spec: @@ -221,9 +194,6 @@ next g \\<^sub>F reference_defs.reference_raw_contract points_to_raw' gref_can_store new_gref_can_store can_alloc_reference g\ by (rule reference_raw_fun_spec) -next - show \\r sh g. ucincl (reference_defs.points_to_raw points_to_raw' r sh g)\ - by (clarsimp simp add: reference_defs.points_to_raw_def ucincl_intros) next show \ucincl can_alloc_reference\ by ucincl_solve diff --git a/Micro_Rust_Interfaces/Raw_Physical_Memory_References.thy b/Micro_Rust_Interfaces/Raw_Physical_Memory_References.thy index e9dc9788..096b6a3f 100644 --- a/Micro_Rust_Interfaces/Raw_Physical_Memory_References.thy +++ b/Micro_Rust_Interfaces/Raw_Physical_Memory_References.thy @@ -37,10 +37,6 @@ proof - by (metis bot.not_eq_extremum zero_share_def) qed -ucincl_auto memset_tagged_phys_contract - load_tagged_physical_address_contract - store_tagged_physical_address_contract - end datatype_record raw_pmem_region = @@ -97,14 +93,12 @@ definition points_to_tagged_phys_bytes :: \64 word \ share \points_to_tagged_phys_bytes addr sh tag bs \ let idxs = [0..\{# points_to_tagged_phys_byte (addr + (word_of_nat idx)) sh tag (bs!idx) \ idx \ idxs #}\ -ucincl_auto points_to_tagged_phys_bytes definition points_to_raw' :: \(raw_pref,8 word list) gref \ share \ 8 word list \ 's assert\ where \points_to_raw' r sh bs \ (let pr = Global_Store.address r in \is_valid_raw_pmem_region pr\ \ \length bs = raw_pmem_region_size pr\ \ (\tag. points_to_tagged_phys_bytes (raw_pmem_region_base pr) sh tag bs))\ -ucincl_auto points_to_raw' definition update_raw_fun :: \(raw_pref, 8 word list) gref \ 8 word list \ ('s, unit, 'abort, 'i prompt, 'o prompt_output) function_body\ where \update_raw_fun r bs \ @@ -147,31 +141,10 @@ definition gref_can_store :: \(raw_pref, 8 word list) gref \ 8 definition new_gref_can_store :: \8 word list set\ where \new_gref_can_store \ {}\ definition can_alloc_reference :: \'s assert\ where \can_alloc_reference \ {}\ +\\The \<^verbatim>\reference\ locale requires allocator availability to be upwards +closed; the registered fact discharges that interpretation obligation below.\ ucincl_auto can_alloc_reference -lemma [ucincl_intros]: - shows \ucincl (function_contract_pre ( - reference_defs.update_raw_contract points_to_raw' gref_can_store a b c))\ - and \ucincl (function_contract_post ( - reference_defs.update_raw_contract points_to_raw' gref_can_store a b c) r)\ - and \ucincl (function_contract_abort ( - reference_defs.update_raw_contract points_to_raw' gref_can_store a b c) ab)\ - and \ucincl (function_contract_pre ( - reference_defs.dereference_raw_contract points_to_raw' x y z))\ - and \ucincl (function_contract_post ( - reference_defs.dereference_raw_contract points_to_raw' x y z) r')\ - and \ucincl (function_contract_abort ( - reference_defs.dereference_raw_contract points_to_raw' x y z) ab)\ - and \ucincl (function_contract_pre ( - reference_defs.reference_raw_contract points_to_raw' gref_can_store new_gref_can_store can_alloc_reference g))\ - and \ucincl (function_contract_post ( - reference_defs.reference_raw_contract points_to_raw' gref_can_store new_gref_can_store can_alloc_reference g) r'')\ - and \ucincl (function_contract_abort ( - reference_defs.reference_raw_contract points_to_raw' gref_can_store new_gref_can_store can_alloc_reference g) ab)\ - by (auto intro!: ucincl_intros simp: reference_defs.update_raw_contract_def - reference_defs.reference_raw_contract_def - reference_defs.dereference_raw_contract_def reference_defs.points_to_raw_def) - lemma update_raw_fun_spec: notes mset_upt [simp del] wp_cong[crush_cong del] @@ -210,16 +183,18 @@ proof - show ?thesis apply (crush_boot f: dereference_raw_fun_def contract: reference_defs.dereference_raw_contract_def) apply (crush_base simp add: Rust_Iterator.map_def collect_def reference_defs.points_to_raw_def - points_to_raw'_def Let_def) - apply (ucincl_discharge\rule_tac \=\\_. {}\ and INV=\\i ls. - \ls = List.take i g\ \ (points_to_tagged_phys_bytes (raw_pmem_region_base (gref_address r)) sh tag g) - \ in wp_gather_framedI'\) + points_to_raw'_def Let_def asepconj_False_True) + apply (rule_tac \=\\_. {}\ and INV=\\i ls. + \ls = List.take i g\ \ points_to_tagged_phys_bytes (raw_pmem_region_base (gref_address r)) sh tag g + \ in wp_gather_framedI') apply (fastcrush_base simp add: iterator_ethunks_def iterator_thunks_def make_iterator_from_list_def is_valid_raw_pmem_region_nat_word_conv specs add: load_physical_address_spec contracts add: load_tagged_physical_address_contract_def) apply (fastcrush_base simp prems add: points_to_tagged_phys_bytes_def) - apply (aentails_float_multi_assms', rule_tac i=\length res\ in aentails_multi_mapped_pick_0L, simp, - fastcrush_base simp add: take_Suc_conv_app_nth simp concls add: points_to_tagged_phys_bytes_def) + apply (aentails_float_multi_assms', + rule_tac i=\length res\ in aentails_multi_mapped_pick_0L, simp) + apply (fastcrush_base simp add: take_Suc_conv_app_nth + simp concls add: points_to_tagged_phys_bytes_def) apply (simp add: aentails_def asepconj_comm asepconj_multi_mapped_pick) done qed @@ -243,17 +218,18 @@ lemma points_to_tagged_bytes_join: reference_defs.points_to_raw points_to_raw' r sh2 v2 \ reference_defs.points_to_raw points_to_raw' r (sh1 + sh2) v1 \ \v1 = v2\\ apply (clarsimp simp add: reference_defs.points_to_raw_def points_to_raw'_def Let_def - points_to_tagged_phys_bytes_def asepconj_simp) + points_to_tagged_phys_bytes_def asepconj_simp) apply crush_base - apply (simp flip: asepconj_multi_split_body add: points_to_tagged_phys_byte_combinesplit - asepconj_multi_split_body asepconj_multi_pure) - apply fastcrush_base - apply (intro nth_equalityI; simp) - apply (simp flip: asepconj_multi_split_body add: points_to_tagged_phys_byte_combinesplit) - apply is_sat_destruct - apply (erule_tac x=i in meta_allE) + apply (simp_all flip: asepconj_multi_split_body asepconj_assoc) + apply (simp add: points_to_tagged_phys_byte_combinesplit asepconj_multi_split_body) + apply (rule aentails_cancel_r_discardable) + apply (intro discardable_in_conj discardable_in_multi discardable_in_apure_preciseI) + apply (auto intro: discardable_in_apure_preciseI) + apply (simp add: points_to_tagged_phys_byte_combinesplit) apply is_sat_destruct - done + apply (intro nth_equalityI; simp) + apply (erule meta_allE, erule meta_impE, assumption) + by is_sat_destruct lemma points_to_tagged_bytes_split: notes mset_upt[simp del] @@ -266,7 +242,7 @@ lemma points_to_tagged_bytes_split: reference_defs.points_to_raw points_to_raw' r sh1 v \ reference_defs.points_to_raw points_to_raw' r sh2 v\ by (fastcrush_base simp add: reference_defs.points_to_raw_def points_to_raw'_def - points_to_tagged_phys_bytes_def seplog drule add: points_to_tagged_phys_byte_split + points_to_tagged_phys_bytes_def seplog drule add: points_to_tagged_phys_byte_split simp flip: asepconj_multi_split_body intro add: aentails_multi_list_pointwise) lemma reference_sublocale: @@ -284,9 +260,6 @@ next g \\<^sub>F reference_defs.reference_raw_contract points_to_raw' gref_can_store new_gref_can_store can_alloc_reference g\ by (rule reference_raw_fun_spec) -next - show \\r sh g. ucincl (reference_defs.points_to_raw points_to_raw' r sh g)\ - unfolding reference_defs.points_to_raw_def by ucincl_solve next show \ucincl can_alloc_reference\ unfolding can_alloc_reference_def by ucincl_solve diff --git a/Micro_Rust_Interfaces/Read_Write_Resource.thy b/Micro_Rust_Interfaces/Read_Write_Resource.thy index c26700aa..7294fc16 100644 --- a/Micro_Rust_Interfaces/Read_Write_Resource.thy +++ b/Micro_Rust_Interfaces/Read_Write_Resource.thy @@ -36,20 +36,20 @@ definition generic_write_contract :: \(share \ 'v \('s::{sepalg}, 'v, 'abort, 'i prompt, 'o prompt_output) rw_resource \ bool\ where \standard_rw_resource r \ - (\sh v. ucincl (rw_resource_is r sh v)) \ (\sh0 sh1 v. 0 < sh0 \ 0 < sh1 \ sh0 \ sh1 \ rw_resource_is r (sh0 + sh1) v \ rw_resource_is r sh0 v \ rw_resource_is r sh1 v) \ (\sh0 sh1 v0 v1. rw_resource_is r sh0 v0 \ rw_resource_is r sh1 v1 - \ \sh0 \ sh1\ \ \v0 = v1\ \ rw_resource_is r (sh0 + sh1) v0) \ + \ \sh0 \ sh1\ \ \v0 = v1\ \ + rw_resource_is r (sh0 + sh1) v0) \ (\\ v. \ ; rw_resource_write r v \\<^sub>F generic_write_contract (rw_resource_is r) v) \ (\\ v sh. \ ; rw_resource_read r \\<^sub>F generic_read_contract (rw_resource_is r) v sh)\ lemma standard_rw_resourceI: - assumes \\sh v. ucincl (rw_resource_is r sh v)\ - and \\sh0 sh1 v. 0 < sh0 \ 0 < sh1 \ sh0 \ sh1 \ + assumes \\sh0 sh1 v. 0 < sh0 \ 0 < sh1 \ sh0 \ sh1 \ rw_resource_is r (sh0 + sh1) v \ rw_resource_is r sh0 v \ rw_resource_is r sh1 v\ and \\sh0 sh1 v0 v1. rw_resource_is r sh0 v0 \ rw_resource_is r sh1 v1 - \ \sh0 \ sh1\ \ \v0 = v1\ \ rw_resource_is r (sh0 + sh1) v0\ + \ \sh0 \ sh1\ \ \v0 = v1\ \ + rw_resource_is r (sh0 + sh1) v0\ and \\\ v. \ ; rw_resource_write r v \\<^sub>F generic_write_contract (rw_resource_is r) v\ and \\\ v sh. \ ; rw_resource_read r \\<^sub>F generic_read_contract (rw_resource_is r) v sh\ shows \standard_rw_resource r\ @@ -67,22 +67,12 @@ lemma standard_rw_resource_write_spec: \\ ; rw_resource_write r v \\<^sub>F generic_write_contract (rw_resource_is r) v\ using assms standard_rw_resource_def by fastforce -\\Don't mark this as \<^verbatim>\ucincl_intros\, but instead specific instantiations -for known standard resources. Otherwise, \<^verbatim>\standard_rw_resource\ assumptions -will pop up in random places in proofs.\ -lemma standard_rw_resource_is_ucincl: - assumes - \standard_rw_resource reg\ - shows - \ucincl (rw_resource_is reg sh v)\ - using assms by (simp add: standard_rw_resource_def) - lemma standard_rw_resource_combine: assumes \standard_rw_resource reg\ shows \rw_resource_is reg sh1 a1 \ rw_resource_is reg sh2 a2 \ rw_resource_is reg (sh1+sh2) a1 \ \sh1\sh2 \ a1 = a2\\ - using assms by (simp add: asepconj_comm asepconj_pure2 standard_rw_resource_def) + using assms by (simp add: asepconj_comm asepconj_pure2_precise standard_rw_resource_def) lemma standard_rw_resource_split: assumes @@ -93,4 +83,4 @@ lemma standard_rw_resource_split: rw_resource_is reg sh1 a \ rw_resource_is reg sh2 a\ using assms by (simp add: standard_rw_resource_def) -end \ No newline at end of file +end diff --git a/Micro_Rust_Interfaces/Transfer_Raw_Physical_Memory.thy b/Micro_Rust_Interfaces/Transfer_Raw_Physical_Memory.thy index 07ba4493..b9e2584d 100644 --- a/Micro_Rust_Interfaces/Transfer_Raw_Physical_Memory.thy +++ b/Micro_Rust_Interfaces/Transfer_Raw_Physical_Memory.thy @@ -24,7 +24,10 @@ begin named_theorems lifted_defs definition [lifted_defs]: \memset_phys a b c \ l\ (memset_phys_lo a b c)\ definition [lifted_defs]: \memset_phys_block x y z \ l\ (memset_phys_block_lo x y z)\ -definition [lifted_defs]: \points_to_tagged_phys_byte x y z t \ l\ (points_to_tagged_phys_byte_lo x y z t)\ +\\A byte accounts exactly for its resource, so every operation in this locale transfers +through the precise pullback.\ +definition [lifted_defs]: \points_to_tagged_phys_byte x y z t \ + l\ (points_to_tagged_phys_byte_lo x y z t)\ definition [lifted_defs]: \store_physical_address x y \ l\ (store_physical_address_lo x y)\ definition [lifted_defs]: \load_physical_address x \ l\ (load_physical_address_lo x)\ definition [lifted_defs]: \tag_physical_page x y tag \ l\ (tag_physical_page_lo x y tag)\ @@ -39,14 +42,104 @@ lemma raw_tagged_physical_memory_contracts_no_abort: and \\a b c d. function_contract_abort (M.store_tagged_physical_address_contract a b c d) = \\ by (simp add: M.all_physical_memory_defs)+ -text\Since \<^verbatim>\l\\ commutes with all constructions carried out in the reference locale, all derived -definitions of functions and contracts are the pullbacks of their counterparts in the source type.\ +text\Precise pullbacks commute with the exact spatial constructions used by these contracts, +including iterated separating conjunction over address ranges.\ lemma raw_tagged_physical_memory_transfer_def_simps: - shows \\a b c d. Defs.memset_tagged_phys_contract a b c d = l\ (M.memset_tagged_phys_contract a b c d)\ - and \\a b c d. Defs.load_tagged_physical_address_contract a b c d = l\ (M.load_tagged_physical_address_contract a b c d)\ - and \\a b c d. Defs.store_tagged_physical_address_contract a b c d = l\ (M.store_tagged_physical_address_contract a b c d)\ - by (clarsimp simp add: slens_pull_back_simps simp add: lifted_defs pull_back_contract_def - raw_tagged_physical_memory_defs.all_physical_memory_defs raw_tagged_physical_memory_contracts_no_abort bot_fun_def)+ + shows \\a b c d. Defs.memset_tagged_phys_contract a b c d = + l\ (M.memset_tagged_phys_contract a b c d)\ + and \\a b c d. Defs.load_tagged_physical_address_contract a b c d = + l\ (M.load_tagged_physical_address_contract a b c d)\ + and \\a b c d. Defs.store_tagged_physical_address_contract a b c d = + l\ (M.store_tagged_physical_address_contract a b c d)\ + \\\<^verbatim>\multiset.map_comp\ and \<^verbatim>\comp_def\ fuse the composed pullback left by + \<^verbatim>\pull_back_asepconj_multi\ into the mapped body used by these definitions.\ + by (clarsimp simp add: lifted_defs slens_pull_back_precise_simps + raw_tagged_physical_memory_defs.all_physical_memory_defs + raw_tagged_physical_memory_contracts_no_abort bot_fun_def + multiset.map_comp comp_def)+ + +lemma memset_phys_lifted: + shows \\; memset_phys pa sz b \\<^sub>F Defs.memset_tagged_phys_contract pa sz tag b\ + unfolding memset_phys_def + by (subst raw_tagged_physical_memory_transfer_def_simps(1)) + (auto simp add: raw_tagged_physical_memory_contracts_no_abort + intro!: pull_back_spec_universal_precise M.memset_phys_spec) + +text\Byte-level obligations transfer because precise pullback preserves \<^term>\(\)\ and +\<^term>\\P\\.\ +lemma points_to_tagged_phys_byte_combine_lifted: + shows \points_to_tagged_phys_byte pa shA tag b \ points_to_tagged_phys_byte pa shB tag' b' + \ points_to_tagged_phys_byte pa (shA + shB) tag b \ + \b = b'\ \ \tag = tag'\ \ \shA \ shB\\ +proof - + have \l\ (points_to_tagged_phys_byte_lo pa shA tag b \ + points_to_tagged_phys_byte_lo pa shB tag' b') + \ l\ (points_to_tagged_phys_byte_lo pa (shA + shB) tag b \ + \b = b'\ \ \tag = tag'\ \ \shA \ shB\)\ + by (intro pull_back_aentailsI M.points_to_tagged_phys_byte_combine) + then show ?thesis + by (simp only: lifted_defs pull_back_asepconj pull_back_assertion_apure_precise) +qed + +lemma points_to_tagged_phys_byte_split_lifted: + assumes \sh = shA + shB\ + and \shA \ shB\ + and \0 < shA\ + and \0 < shB\ + shows \points_to_tagged_phys_byte pa sh tag b \ + points_to_tagged_phys_byte pa shA tag b \ points_to_tagged_phys_byte pa shB tag b\ +proof - + from assms have \points_to_tagged_phys_byte_lo pa sh tag b \ + points_to_tagged_phys_byte_lo pa shA tag b \ points_to_tagged_phys_byte_lo pa shB tag b\ + by (rule M.points_to_tagged_phys_byte_split) + then show ?thesis + by (simp only: lifted_defs pull_back_asepconj[symmetric] pull_back_aentails) +qed + +lemma points_to_tagged_phys_byte_empty_share_lifted: + shows \points_to_tagged_phys_byte pa 0 tag b = {}\ + by (simp add: lifted_defs M.points_to_tagged_phys_byte_empty_share + pull_back_assertion_false) + +text\The partially applied byte under \<^term>\range\ needs a dedicated pullback equation.\ +lemma pull_back_byte_range: + shows \\ (range (points_to_tagged_phys_byte pa sh tag)) = + l\ (\ (range (points_to_tagged_phys_byte_lo pa sh tag)))\ + by (auto simp add: lifted_defs pull_back_assertion_def) + +lemma raw_tagged_physical_memory_block_contract_transfer: + shows \make_function_contract (Defs.memset_tagged_block_pre pa n tag) + (\_. Defs.memset_tagged_block_post pa n tag b) = + l\ (make_function_contract (M.memset_tagged_block_pre pa n tag) + (\_. M.memset_tagged_block_post pa n tag b))\ + and \make_function_contract (Defs.taggable_physical_block pa n tag f) + (\_. Defs.tagged_physical_block pa n tag f) = + l\ (make_function_contract (M.taggable_physical_block pa n tag f) + (\_. M.tagged_physical_block pa n tag f))\ + by (clarsimp simp add: lifted_defs pull_back_byte_range slens_pull_back_precise_simps + multiset.map_comp comp_def bot_fun_def)+ + +lemma memset_phys_block_lifted: + assumes \n \ raw_tagged_physical_memory_bitwidth\ + and \Defs.is_within_bounds pa\ + and \is_aligned pa n\ + shows \\; memset_phys_block pa n b \\<^sub>F + make_function_contract (Defs.memset_tagged_block_pre pa n tag) + (\_. Defs.memset_tagged_block_post pa n tag b)\ + unfolding memset_phys_block_def + by (subst raw_tagged_physical_memory_block_contract_transfer(1)) + (auto simp add: assms intro!: pull_back_spec_universal_precise M.memset_phys_block_spec) + +lemma tag_physical_page_lifted: + assumes \n \ raw_tagged_physical_memory_bitwidth\ + and \Defs.is_within_bounds pa\ + and \is_aligned pa n\ + shows \\; tag_physical_page pa n tag \\<^sub>F + make_function_contract (Defs.taggable_physical_block pa n tag f) + (\_. Defs.tagged_physical_block pa n tag f)\ + unfolding tag_physical_page_def + by (subst raw_tagged_physical_memory_block_contract_transfer(2)) + (auto simp add: assms intro!: pull_back_spec_universal_precise M.tag_physical_page_spec) lemma raw_tagged_physical_memory_lifted: shows \raw_tagged_physical_memory memset_phys memset_phys_block @@ -54,11 +147,15 @@ lemma raw_tagged_physical_memory_lifted: load_physical_address tag_physical_page\ using M.all_raw_tagged_physical_memory_specs apply - - apply (standard; (simp add: raw_tagged_physical_memory_transfer_def_simps)?) - apply (clarsimp simp add: raw_tagged_physical_memory_contracts_no_abort pull_back_spec_universal - lifted_defs intro!: slens_pull_back_intros simp flip: slens_pull_back_simps)+ + apply (standard; (simp add: memset_phys_lifted points_to_tagged_phys_byte_combine_lifted + points_to_tagged_phys_byte_split_lifted points_to_tagged_phys_byte_empty_share_lifted + memset_phys_block_lifted tag_physical_page_lifted)?) + \\The remaining load and store contracts contain no iterated conjunction and transport + directly.\ + apply (clarsimp simp add: raw_tagged_physical_memory_transfer_def_simps + raw_tagged_physical_memory_contracts_no_abort lifted_defs pull_back_spec_universal_precise)+ done end -end \ No newline at end of file +end diff --git a/Micro_Rust_Interfaces/Transfer_References.thy b/Micro_Rust_Interfaces/Transfer_References.thy index a4ba347d..0c370c97 100644 --- a/Micro_Rust_Interfaces/Transfer_References.thy +++ b/Micro_Rust_Interfaces/Transfer_References.thy @@ -38,24 +38,41 @@ named_theorems lifted_defs definition [lifted_defs]: \update_raw_fun r g \ l\ (update_raw_fun_lo r g)\ definition [lifted_defs]: \dereference_raw_fun r \ l\ (dereference_raw_fun_lo r)\ definition [lifted_defs]: \reference_raw_fun r \ l\ (reference_raw_fun_lo r)\ +\\Points-to assertions transfer precisely, while the upwards-closed allocator assertion +transfers framed.\ definition [lifted_defs]: \points_to_raw' r sh g \ l\ (points_to_raw'_lo r sh g)\ -definition [lifted_defs]: \can_alloc_reference \ l\ can_alloc_reference_lo\ +definition [lifted_defs]: \can_alloc_reference \ + pull_back_assertion_framed l can_alloc_reference_lo\ interpretation Defs: reference_defs \\(_::'s) (_::'a) (_::'b) (_ :: 'abort) (_:: 'i prompt) (_::'o prompt_output). ()\ update_raw_fun dereference_raw_fun reference_raw_fun points_to_raw' gref_can_store_lo new_gref_can_store_lo can_alloc_reference . -text\Since \<^verbatim>\l\\ commutes with all constructions carried out in the reference locale, all derived -definitions of functions and contracts are the pullbacks of their counterparts in the source type.\ +text\Reference transfer uses precise pullbacks for exact points-to assertions and framed +pullbacks for allocator assertions.\ lemma reference_transfer_def_simps: shows \Defs.update_raw_contract rr g0 g = l\ (R.update_raw_contract rr g0 g)\ and \Defs.dereference_raw_contract rr sh g = l\ (R.dereference_raw_contract rr sh g)\ - and \Defs.reference_raw_contract v = l\ (R.reference_raw_contract v)\ + and \Defs.reference_raw_contract v = + pull_back_contract_framed l (R.reference_raw_contract v)\ and \Defs.points_to_raw rr sh g = l\ (R.points_to_raw rr sh g)\ and \Defs.points_to r sh g v = l\ (R.points_to r sh g v)\ - by (clarsimp simp add: lifted_defs pull_back_contract_def comp_def slens_pull_back_simps + apply (clarsimp simp add: lifted_defs pull_back_contract_framed_def pull_back_contract_def + comp_def slens_pull_back_precise_simps + pull_back_assertion_framed_apure_precise_asepconj + pull_back_assertion_framed_asepconj_apure_precise + pull_back_assertion_framed_asepconj_apure_precise_asepconj + pull_back_assertion_framed_false + pull_back_assertion_mixed_asepconj + pull_back_assertion_mixed_asepconj' (* All definitions in the reference locale *) reference_defs.all_reference_defs bot_fun_def)+ + \\The framed allocator factor absorbs the lens kernel in the mixed contract.\ + apply (simp only: pull_back_assertion_framed_absorbs_precise) + apply (simp add: lifted_defs reference_defs.points_to_raw_def) + apply (simp add: lifted_defs reference_defs.points_to_def reference_defs.points_to_raw_def + slens_pull_back_precise_simps) + done text\Applying the various (non-trivial) theorems for transporting specs along pullbacks, we now formally derive the correctness of the pulled back reference implementation:\ @@ -71,9 +88,19 @@ lemma reference_lifted: \reference gref_can_store_lo new_gref_can_store_lo can_alloc_reference\ using R.all_reference_specs apply - apply (standard; simp add: reference_transfer_def_simps) - by (auto simp add: reference_contracts_no_abort pull_back_spec_universal lifted_defs - intro!: slens_pull_back_intros simp flip: slens_pull_back_simps) + \\Framed obligations use only framed rules backwards; precise rules are oriented inward.\ + apply (auto simp add: reference_contracts_no_abort pull_back_spec_universal lifted_defs + intro!: slens_pull_back_intros + simp flip: pull_back_assertion_framed_asepconj + pull_back_assertion_framed_apure_precise_asepconj + pull_back_assertion_framed_asepconj_apure_precise) + \\Exact points-to obligations use precise transport.\ + apply (auto simp add: reference_contracts_no_abort intro!: pull_back_spec_universal_precise) + apply (metis R.points_to_raw_combine pull_back_aentailsI pull_back_asepconj + pull_back_assertion_apure_precise) + apply (metis R.points_to_raw_split pull_back_aentailsI pull_back_asepconj) + done end -end \ No newline at end of file +end diff --git a/Micro_Rust_Interfaces_Core/Raw_Physical_Memory.thy b/Micro_Rust_Interfaces_Core/Raw_Physical_Memory.thy index ef00a5dd..86fce7fd 100644 --- a/Micro_Rust_Interfaces_Core/Raw_Physical_Memory.thy +++ b/Micro_Rust_Interfaces_Core/Raw_Physical_Memory.thy @@ -104,8 +104,8 @@ assumes load_physical_address_spec [all_raw_tagged_physical_memory_specs]: \ is_aligned pa n \ \; memset_tagged_phys_block pa n b \\<^sub>F make_function_contract (memset_tagged_block_pre pa n tag) (\_. memset_tagged_block_post pa n tag b)\ - and points_to_tagged_phys_byte_ucincl[ucincl_intros, all_raw_tagged_physical_memory_specs]: - \\a b c d. ucincl (points_to_tagged_phys_byte a b c d)\ + \\Byte assertions describe concrete resource and carry no upwards-closure requirement. + A model may still provide closure when it is inherent in the representation.\ and points_to_tagged_phys_byte_empty_share[all_raw_tagged_physical_memory_specs]: \\pa b tag. points_to_tagged_phys_byte pa 0 tag b = {}\ @@ -120,4 +120,4 @@ assumes load_physical_address_spec [all_raw_tagged_physical_memory_specs]: points_to_tagged_phys_byte pa shA tag b \ points_to_tagged_phys_byte pa shB tag' b' \ points_to_tagged_phys_byte pa (shA + shB) tag b \ \b = b'\ \ \tag = tag'\ \ \shA \ shB\\ -end \ No newline at end of file +end diff --git a/Micro_Rust_Interfaces_Core/References.thy b/Micro_Rust_Interfaces_Core/References.thy index eeba1309..c4ce4cb2 100644 --- a/Micro_Rust_Interfaces_Core/References.thy +++ b/Micro_Rust_Interfaces_Core/References.thy @@ -115,7 +115,8 @@ abbreviation points_to_localizes :: \('a, 'b, 'v) Global_Store.ref \ focus_view (get_focus r) b = Some v\ definition points_to :: \('a, 'b, 'v) Global_Store.ref \ share \ 'b \ 'v \ 's assert\ where - [all_reference_defs']: \points_to r sh b v \ points_to_raw (unwrap_focused r) sh b \ \points_to_localizes r b v\\ + [all_reference_defs']: \points_to r sh b v \ + points_to_raw (unwrap_focused r) sh b \ \points_to_localizes r b v\\ notation points_to ("(_) \ \_\/_/ \/ _" [69,0,69,69]70) @@ -160,7 +161,8 @@ definition ro_dereference_contract definition reference_contract :: \('b, 'v) prism \ 'v \ ('s, ('a, 'b, 'v) Global_Store.ref, 'abort) function_contract\ where [all_reference_defs']: \reference_contract p v \ let pre = can_alloc_reference in - let post = \r. points_to r \ (prism_embed p v) v \ \\r = prism_to_focus p\ \ can_alloc_reference in + let post = \r. points_to r \ (prism_embed p v) v \ + \\r = prism_to_focus p\ \ can_alloc_reference in make_function_contract pre post\ lemmas all_reference_defs = all_reference_defs' @@ -184,20 +186,20 @@ locale reference = reference_defs reference_types and dereference_raw_spec[all_reference_specs]: \\ ; dereference_raw_fun r \\<^sub>F dereference_raw_contract r sh g\ and reference_raw_spec[all_reference_specs]: \\ ; reference_raw_fun g \\<^sub>F reference_raw_contract g\ - and ucincl_points_to_raw[ucincl_intros, all_reference_specs]: \\r sh g. ucincl (points_to_raw r sh g)\ + \\Points-to assertions account for concrete resource and carry no upwards-closure + assumption; allocator availability remains upwards closed.\ and ucincl_can_alloc_reference[ucincl_intros, all_reference_specs]: \ucincl can_alloc_reference\ - and points_to_raw_combine[all_reference_specs]: - \\r sh1 sh2 v1 v2. r \\sh1\ v1 \ r \\sh2\ v2 \ r \\sh1+sh2\ v1 \ \v1 = v2\\ + \\Share combination returns value agreement as a precise-pure factor, preserving all + resource ownership.\ + and points_to_raw_combine[all_reference_specs]: + \\r sh1 sh2 v1 v2. r \\sh1\ v1 \ r \\sh2\ v2 + \ r \\sh1+sh2\ v1 \ \v1 = v2\\ and points_to_raw_split[all_reference_specs]: \\sh shA shB r v. sh = shA+shB \ shA \ shB \ 0 < shA \ 0 < shB \ r \\sh\ v \ r \\shA\ v \ r \\shB\ v\ begin -lemma points_to_raw'_ucincl[ucincl_intros]: - shows \\r sh g. ucincl (points_to_raw' r sh g)\ - using ucincl_points_to_raw unfolding points_to_raw_def by simp - lemma points_to_raw_aentails[intro]: assumes \g0 = g1\ shows \r \\sh\ g0 \ r \\sh\ g1\ @@ -212,7 +214,7 @@ using assms by (auto intro!: aentails_refl) lemma aentails_split_single_points_to_assm: assumes \points_to_localizes r g v \ \ r \\sh\ g \ \\ shows \r\\sh\ g\v \ \\ -by (metis (full_types) apure_entailsL asepconj_comm assms points_to_def ucincl_points_to_raw) + by (metis apure_precise_entailsL asepconj_comm assms reference_defs.points_to_def) lemma aentails_split_top_points_to_assm: assumes \points_to_localizes r g v \ \ r \\sh\ g \ \ \ \\ @@ -232,7 +234,7 @@ lemma aentails_cancel_points_to_raw_with_typed_0LR: and \g' = g\ and \points_to_localizes r g v\ shows \rr'\\sh\ g' \ r\\sh\ g\v\ -using assms by (simp add: aentails_def points_to_def ucincl_points_to_raw) +using assms by (simp add: aentails_def points_to_def asepconj_simp) lemma aentails_cancel_points_to_raw_with_typed_0L: assumes \rr' = \ r\ @@ -244,9 +246,10 @@ using assms by (simp add: asepconj_mono points_to_def) lemma aentails_cancel_points_to_raw_with_typed_0R: assumes \rr' = \ r\ and \g' = g\ - and \\ \ \points_to_localizes r g v\ \ \\ - shows \rr'\\sh\ g' \ r\\sh\ g\v \ \\ - using aentails_cancel_points_to_raw_with_typed by (metis asepconj_ident2 assms ucincl_points_to_raw) + and \emp \ \points_to_localizes r g v\ \ \\ + shows \rr'\\sh\ g' \ r\\sh\ g\v \ \\ + using aentails_cancel_points_to_raw_with_typed + by (simp add: asepconj_assoc asepconj_mono5 assms(1,2,3) points_to_def) declare reference_axioms [reference_axioms] (*<*) diff --git a/Micro_Rust_Runtime/Atomic_Resource.thy b/Micro_Rust_Runtime/Atomic_Resource.thy index 65f1c247..229a3755 100644 --- a/Micro_Rust_Runtime/Atomic_Resource.thy +++ b/Micro_Rust_Runtime/Atomic_Resource.thy @@ -53,12 +53,12 @@ definition read_atomic_value :: \('v option, 'v, 'abort, 'i, 'o) function_ definition read_atomic_value_contract :: \'v \ ('v option, 'v, 'abort) function_contract\ where \read_atomic_value_contract \ \v. let pre = atomic_value_is v in - let post = \r. atomic_value_is v \ \r = v\ in + let post = \r. atomic_value_is v \ apure (r = v) in make_function_contract pre post\ lemma read_atomic_value_contract_no_abort: shows \function_contract_abort (read_atomic_value_contract b) = \\ - by (simp add: read_atomic_value_contract_def pull_back_contract_def) + by (simp add: read_atomic_value_contract_def pull_back_contract_framed_def) lemma read_atomic_value_spec: shows \\; read_atomic_value \\<^sub>F read_atomic_value_contract v\ @@ -133,7 +133,7 @@ definition write_atomic_value_contract :: \'v \ ('v option, un lemma write_atomic_value_contract_no_abort: shows \function_contract_abort (write_atomic_value_contract a) = \\ - by (simp add: write_atomic_value_contract_def pull_back_contract_def) + by (simp add: write_atomic_value_contract_def pull_back_contract_framed_def) lemma write_atomic_value_spec: shows \\; write_atomic_value v \\<^sub>F write_atomic_value_contract v\ @@ -152,7 +152,7 @@ mechanism to obtain read/write functions on the larger separation algebra:\('s, 'v option) lens\ definition atomic_resource_is :: \('s, 'v) atomic_resource \ 'v \ 's assert\ - where \atomic_resource_is l v \ l\ (atomic_value_is v)\ + where \atomic_resource_is l v \ pull_back_assertion_framed l (atomic_value_is v)\ definition read_atomic_resource :: \('s, 'v) atomic_resource \ ('s, 'v, 'abort, 'i, 'o) function_body\ where \read_atomic_resource l \ l\ read_atomic_value\ @@ -161,20 +161,22 @@ definition write_atomic_resource :: \('s, 'v) atomic_resource\ where \write_atomic_resource l v \ l\ (write_atomic_value v)\ definition read_atomic_resource_contract :: \('s::sepalg, 'v) atomic_resource \ 'v \ ('s, 'v, 'abort) function_contract\ - where \read_atomic_resource_contract l v \ l\ (read_atomic_value_contract v)\ + where \read_atomic_resource_contract l v \ + pull_back_contract_framed l (read_atomic_value_contract v)\ lemma read_atomic_resource_contract_no_abort: shows \function_contract_abort (read_atomic_resource_contract a b) = \\ - by (simp add: read_atomic_value_contract_no_abort read_atomic_resource_contract_def pull_back_contract_def - pull_back_assertion_def bot_fun_def) + by (simp add: read_atomic_value_contract_no_abort read_atomic_resource_contract_def pull_back_contract_framed_def + pull_back_assertion_framed_def bot_fun_def) definition write_atomic_resource_contract :: \('s::sepalg, 'v) atomic_resource \ 'v \ ('s, unit, 'abort) function_contract\ - where \write_atomic_resource_contract l v \ l\ (write_atomic_value_contract v)\ + where \write_atomic_resource_contract l v \ + pull_back_contract_framed l (write_atomic_value_contract v)\ lemma write_atomic_resource_contract_no_abort: shows \function_contract_abort (write_atomic_resource_contract a b) = \\ - by (simp add: write_atomic_value_contract_no_abort write_atomic_resource_contract_def pull_back_contract_def - pull_back_assertion_def bot_fun_def) + by (simp add: write_atomic_value_contract_no_abort write_atomic_resource_contract_def pull_back_contract_framed_def + pull_back_assertion_framed_def bot_fun_def) lemma read_atomic_resource_spec: assumes \is_valid_slens l\ @@ -188,4 +190,4 @@ lemma write_atomic_resource_spec: by (simp add: assms slens.pull_back_spec_universal write_atomic_resource_contract_def write_atomic_resource_def write_atomic_value_spec write_atomic_value_contract_no_abort) -end \ No newline at end of file +end diff --git a/Micro_Rust_Runtime/Raw_Physical_Memory_Trie.thy b/Micro_Rust_Runtime/Raw_Physical_Memory_Trie.thy index 7ed00aa3..c5cee3e7 100644 --- a/Micro_Rust_Runtime/Raw_Physical_Memory_Trie.thy +++ b/Micro_Rust_Runtime/Raw_Physical_Memory_Trie.thy @@ -116,7 +116,7 @@ qed corollary points_to_tagged_phys_byte_ucincl'': shows \points_to_tagged_phys_byte pa \ tag b \ UNIV = points_to_tagged_phys_byte pa \ tag b\ and \UNIV \ points_to_tagged_phys_byte pa \ tag b = points_to_tagged_phys_byte pa \ tag b\ - and \points_to_tagged_phys_byte pa \ tag b \ \P\ = points_to_tagged_phys_byte pa \ tag b \ \P\\ + and \points_to_tagged_phys_byte pa \ tag b \ apure P = points_to_tagged_phys_byte pa \ tag b \ apure P\ by (auto simp add: asepconj_comm asepconj_ident points_to_tagged_phys_byte_ucincl' asepconj_pure') @@ -257,16 +257,16 @@ proof (ucincl_discharge \intro satisfies_function_contractI\; clars by (auto simp add: load_tagged_physical_address_core_is_local load_tagged_physical_address_def eval_abort_def) moreover from calculation have \points_to_tagged_phys_byte pa \ tag b \ eval_value (yh \) (function_body (load_tagged_physical_address pa)) \\<^sub>R - (\r. points_to_tagged_phys_byte pa \ tag b \ \r = b\)\ + (\r. points_to_tagged_phys_byte pa \ tag b \ \r = b\)\ by (force simp add: atriple_rel_def eval_value_def load_tagged_physical_address_def asepconj_False_True load_tagged_phys_byte_def urust_eval_predicate_load_tagged_physical_address_core) moreover from calculation have \points_to_tagged_phys_byte pa \ tag b \ eval_return (yh \) (function_body (load_tagged_physical_address pa)) \\<^sub>R - (\r. points_to_tagged_phys_byte pa \ tag b \ \r = b\)\ + (\r. points_to_tagged_phys_byte pa \ tag b \ \r = b\)\ by (clarsimp simp add: atriple_rel_def eval_return_def eval_value_def load_tagged_physical_address_def urust_eval_predicate_load_tagged_physical_address_core) moreover have \\ \\<^sub>a \yh \, function_body (load_tagged_physical_address pa)\ (a, \') = False\ - if \\ \ points_to_tagged_phys_byte pa \ tag b \ \\ for \ a \' + if \\ \ points_to_tagged_phys_byte pa \ tag b\ for \ a \' using that by (metis function_body.sel load_tagged_physical_address_def points_to_tagged_phys_byte_not_core points_to_tagged_phys_byte_ucincl''(1)) @@ -274,7 +274,7 @@ proof (ucincl_discharge \intro satisfies_function_contractI\; clars eval_abort (yh \) (function_body (load_tagged_physical_address pa)) \\<^sub>R \\ by (clarsimp simp add: eval_abort_def atriple_rel_def) ultimately show \\ ; points_to_tagged_phys_byte pa \ tag b \ function_body (load_tagged_physical_address pa) \ - (\r. points_to_tagged_phys_byte pa \ tag b \ \r = b\) \ (\r. points_to_tagged_phys_byte pa \ tag b \ \r = b\) \ \\ + (\r. points_to_tagged_phys_byte pa \ tag b \ \r = b\) \ (\r. points_to_tagged_phys_byte pa \ tag b \ \r = b\) \ \\ by (intro sstripleI; clarsimp) qed @@ -431,10 +431,8 @@ using assms proof (induction n arbitrary: \ pa) by force moreover from calculation have \\ \ points_to_tagged_phys_byte pa \ tag (f pa)\ by (force intro: points_to_tagged_phys_byteI) - moreover from calculation have \\ \ points_to_tagged_phys_byte pa \ tag (f pa) \ \\ - by (subst asepconj_ident2) auto ultimately show \\ \ raw_tagged_pmem_defs.tagged_physical_block pa 0 tag f\ - by (clarsimp simp add: asepconj_simp) + by (clarsimp simp add: asepconj_simp asepconj_emp_unit) next fix n \ pa assume \is_aligned pa (Suc n)\ @@ -529,10 +527,8 @@ proof - qed moreover { fix \ e - assume \\ \ raw_tagged_pmem_defs.memset_tagged_block_pre pa n tag \ UNIV\ + assume \\ \ raw_tagged_pmem_defs.memset_tagged_block_pre pa n tag\ and \physical_memory_memset_block \ pa n b = Inl e\ - moreover from this have \ucincl (raw_tagged_pmem_defs.memset_tagged_block_pre pa n tag)\ - by ucincl_solve moreover from calculation have \\ \ raw_tagged_pmem_defs.memset_tagged_block_pre pa n tag\ by (auto simp add: asepconj_ident2) moreover from calculation have \\ \ \\ {# \ (range (points_to_tagged_phys_byte a \ tag)) . a \ mset_set (block_range pa n) #}\ @@ -544,10 +540,6 @@ proof - ultimately have \False\ by clarsimp } - moreover have \ucincl (\\ {# \ (range (points_to_tagged_phys_byte a \ tag)) . a \ mset_set (block_range pa n) #})\ - by ucincl_solve - moreover have \ucincl (raw_tagged_pmem_defs.memset_tagged_block_post pa n tag b)\ - by ucincl_solve moreover from calculation assms have \is_local (\\ (x, y). \ \\<^sub>v \yh \, function_body (memset_tagged_phys_block pa n b)\ (x,y)) (\\ {# \ (range (points_to_tagged_phys_byte a \ tag)) . a \ mset_set (block_range pa n) #})\ by (simp add: memset_phys_block_core_is_local memset_tagged_phys_block_def) moreover from calculation assms have \is_local (\\ (x, y). \ \\<^sub>r \yh \,function_body (memset_tagged_phys_block pa n b)\ (x,y)) (\\ {# \ (range (points_to_tagged_phys_byte a \ tag)) . a \ mset_set (block_range pa n) #})\ @@ -567,20 +559,6 @@ qed named_theorems asat_elims -lemma asat_multiE: - assumes \\ \ \\ \\ - and \\x. x \# \ \ ucincl x\ - and \(\\. \ \# \ \ \ \ \) \ R\ - shows R - by (metis aentailsE aentails_cancel_r asepconj_add_mset assms multi_member_split) - -corollary asat_multiE2[asat_elims]: - assumes \\ \ \\{# \ x . x \ ms #}\ - and \\x. x \# ms \ ucincl (\ x)\ - and \(\x. x \# ms \ \ \ \ x) \ R\ - shows R - using assms by (elim asat_multiE; clarsimp) - lemma asat_asepconjE[asat_elims]: assumes \\ \ \ \ \\ and \ucincl \\ @@ -589,6 +567,16 @@ lemma asat_asepconjE[asat_elims]: shows R using assms by (meson asepconj_strengthenE asepconj_strengthenE2) +text\An exact iterated conjunction yields each factor with the remaining state as a frame.\ +lemma asat_multi_focusE: + assumes \\ \ \\ {# \ x. x \ xs #}\ + and \(\x. x \# xs \ \ \ \ x \ \) \ R\ + shows \R\ + using assms + apply (erule_tac meta_impE; simp?) + by (force simp add: asat_def asepconj_def asepconj_add_mset + dest!: multi_member_split) + declare apureE[asat_elims] and asat_existsE[asat_elims] and asat_existsE'[asat_elims] @@ -599,10 +587,14 @@ lemma tagged_physical_block_byte_state: and \x \ block_range pa n\ shows \physical_memory_lookup \ x = Tagged \ tag (f x)\ proof - - have \\a. a \ block_range pa n \ \ \ points_to_tagged_phys_byte a \ tag (f a)\ - using assms by (auto simp: ucincl_intros elim!: asat_elims) - with \x \ block_range pa n\ show ?thesis - using nonempty_share_top_eq top.extremum_unique by fastforce + from assms have \a \ block_range pa n \ \ \ points_to_tagged_phys_byte a \ tag (f a) \ UNIV\ for a + apply (elim asat_multi_focusE) + apply (drule meta_spec[of _ a]) + by (clarsimp simp add: asepconj_Inf_distrib asepconj_assoc) + from this[OF \x \ block_range pa n\] show ?thesis + apply (auto simp add: points_to_tagged_phys_byte_ucincl' elim!: asat_asepconjE) + using nonempty_share_top_eq top.extremum_unique + by (fastforce simp add: asat_def points_to_tagged_phys_byte_def) qed lemma taggable_physical_block_byte_state: @@ -610,10 +602,22 @@ lemma taggable_physical_block_byte_state: and \x \ block_range pa n\ shows \\tag'. tag \ tag' \ physical_memory_lookup \ x = Tagged \ tag' (f x)\ proof - - obtain tag' where \\ \ \tag' \ tag\ \ points_to_tagged_phys_byte x \ tag' (f x)\ - using assms by (force simp: ucincl_IntE ucincl_Un ucincl_apure ucincl_asepconjL elim!: asat_elims) - with \x \ block_range pa n\ show ?thesis - by (auto simp: ucincl_apure nonempty_share_top_eq top.extremum_unique points_to_tagged_phys_byte_ucincl' elim!: asat_elims) + obtain tag' where sat: + \\ \ \tag' \ tag\ \ points_to_tagged_phys_byte x \ tag' (f x) \ UNIV\ + using assms + apply (elim asat_multi_focusE) + apply (drule meta_spec[of _ x]) + by (clarsimp simp add: asepconj_Inf_distrib asepconj_assoc) + \\The precise-pure tag constraint separates without a closure premise.\ + from sat have ne: \tag' \ tag\ + and byte: \\ \ points_to_tagged_phys_byte x \ tag' (f x) \ UNIV\ + by (simp_all add: asat_apure_precise_distrib) + from byte have \physical_memory_lookup \ x = Tagged \ tag' (f x)\ + apply (auto simp add: points_to_tagged_phys_byte_ucincl' elim!: asat_asepconjE) + using nonempty_share_top_eq top.extremum_unique + by (fastforce simp add: asat_def points_to_tagged_phys_byte_def) + with ne show ?thesis + by (intro exI[of _ tag']) auto qed lemma taggable_physical_block_byte_stateE: @@ -708,10 +712,8 @@ proof (intro satisfies_function_contractI; clarsimp; ucincl_solve?) moreover { note calculation_thus_far = this fix \ a \' - assume \\ \ raw_tagged_pmem_defs.taggable_physical_block pa n tag f \ \\ + assume \\ \ raw_tagged_pmem_defs.taggable_physical_block pa n tag f\ and \\ \\<^sub>a \yh \,function_body (tag_physical_page pa n tag)\ (a, \')\ - moreover have \ucincl (raw_tagged_pmem_defs.taggable_physical_block pa n tag f)\ - by ucincl_solve moreover from calculation have \\ \ raw_tagged_pmem_defs.taggable_physical_block pa n tag f\ using asepconj_strengthenE ucincl_UNIV by blast ultimately have \False\ @@ -730,12 +732,6 @@ proof (intro satisfies_function_contractI; clarsimp; ucincl_solve?) by (intro sstriple_from_stripleI) (auto simp add: eval_value_def eval_return_def eval_abort_def) qed -lemma memset_phys_contract_ucincl: - shows [ucincl_intros]: \ucincl (function_contract_pre (raw_tagged_pmem_defs.memset_tagged_phys_contract pa l tag b))\ - and [ucincl_intros]: \ucincl (function_contract_post (raw_tagged_pmem_defs.memset_tagged_phys_contract pa l tag b) r)\ - and [ucincl_intros]: \ucincl (function_contract_abort (raw_tagged_pmem_defs.memset_tagged_phys_contract pa l tag b) r')\ - by (ucincl_solve simp: raw_tagged_pmem_defs.memset_tagged_phys_contract_def) - lemma block_range_to_page_range: assumes \is_aligned adr l\ shows \block_range adr l = page_range_word adr l\ @@ -813,14 +809,14 @@ lemma memset_phys_spec[raw_tagged_pmem_spec_specs]: and wp_cong'[crush_cong del] shows \\; memset_tagged_phys pa l b \\<^sub>F raw_tagged_pmem_defs.memset_tagged_phys_contract pa l tag b\ apply (crush_boot f: memset_tagged_phys_def contract: raw_tagged_pmem_defs.memset_tagged_phys_contract_def) - apply (clarsimp simp add: range_to_aligned_blocks_block_range) + apply (clarsimp simp add: range_to_aligned_blocks_block_range mset_set_empty_iff) apply (crush_base simp add: list_into_iter_def) apply (rule_tac \=\\\ and INV=\\ls i. \\ {# \ (range (points_to_tagged_phys_byte a \ tag)) . a \ mset_set (\an\set (List.drop i ls). block_range (fst an) (snd an)) #} \ \\ {# points_to_tagged_phys_byte a \ tag b . a \ mset_set (\an\set (List.take i ls). block_range (fst an) (snd an)) #}\ - in wp_raw_for_loop_framedI', ucincl_solve) + in wp_raw_for_loop_framedI') apply (fastcrush_base split: prod.splits simp add: take_Suc_conv_app_nth drop_Suc_nth) subgoal for i apply (rule wp_callI[OF memset_phys_block_spec]; (simp add: PMEM_TRIE_ADDRESS_WIDTH_def)?) @@ -838,7 +834,7 @@ lemma memset_phys_spec[raw_tagged_pmem_spec_specs]: apply (subst mset_set_Union; (simp add: finite_block_range)?) apply (safe; clarsimp simp add: raw_tagged_pmem_defs.is_within_bounds_def in_set_conv_nth) apply (case_tac \range_to_aligned_blocks pa l ! i\; clarsimp) - apply (meson order_less_trans range_to_aligned_blocks_disjoint) + using range_to_aligned_blocks_disjoint [where j=i] apply force apply fastcrush_base done done @@ -934,7 +930,8 @@ lemma physical_memory_singleton_tagged_split_alt'': fixes sh1 sh2 :: nonempty_share assumes \pa < PMEM_TRIE_ADDRESS_LIMIT\ shows \{PSINGLE pa v sh1 tag} \ {PSINGLE pa v' sh2 tag'} \ \ = - {PSINGLE pa v (sh1 + sh2) tag} \ \tag = tag'\ \ \v = v'\ \ \\ sh1 \ \ sh2\\ + {PSINGLE pa v (sh1 + sh2) tag} \ apure (tag = tag') \ apure (v = v') \ + apure (\ sh1 \ \ sh2)\ using assms by (cases \v = v'\; cases \tag = tag'\; cases \\ sh1 \ \ sh2\) (auto simp flip: asepconj_assoc simp add: physical_memory_singleton_tagged_split_alt' simp add: asepconj_simp apure_def) @@ -1055,10 +1052,6 @@ next by (metis Abs_nonempty_share_inverse less_supI1 mem_Collect_eq plus_share_def zero_share_def) moreover from this have \shA + shB = \ (shA' + shB')\ by (simp add: plus_nonempty_share.rep_eq plus_share_def) - moreover from calculation and points_to_tagged_phys_byte_singleton have - \P(pa:(shA + shB):tag:b) = {PSINGLE pa b (shA' + shB') tag } \ \\ and - \P(pa:shA:tag:b) = {PSINGLE pa b shA' tag} \ \\ and \P(pa:shB:tag':b') = {PSINGLE pa b' shB' tag'} \ \\ - by (metis less)+ ultimately show ?thesis using less apply (simp add: points_to_tagged_phys_byte_singleton) @@ -1067,10 +1060,8 @@ next apply (aentails_pick_assm 1, clarsimp simp add: physical_memory_singleton_tagged_split_alt'') apply (aentails_cancel, clarsimp simp add: asepconj_simp ucincl_intros aentails_simp is_sat_pure intro!: apure_entailsR0) - apply (aentails_pick_concl 2, clarsimp simp add: asepconj_simp) - apply (aentails_pick_concl 1, clarsimp simp add: physical_memory_singleton_tagged_split_alt'') - apply (aentails_cancel, clarsimp simp add: asepconj_simp ucincl_intros aentails_simp is_sat_pure - intro!: apure_entailsR0) + apply (crush_base seplog drule add: + physical_memory_singleton_tagged_split_alt[THEN aentails_refl_eq]) done qed qed @@ -1087,7 +1078,7 @@ using assms by (fastcrush_base simp add: points_to_tagged_phys_byte_split_core) lemma points_to_tagged_phys_byte_combine [raw_tagged_pmem_spec_specs]: fixes pa shA shB b b' shows \P(pa:shA:tag:b) \ P(pa:shB:tag':b') \ P(pa:(shA + shB):tag:b) \ \tag = tag'\ \ \b = b'\ \ \shA \ shB\\ -by (clarsimp simp add: points_to_tagged_phys_byte_split_core) fastcrush_base + by (clarsimp simp add: points_to_tagged_phys_byte_split_core) fastcrush_base no_notation physical_memory_singleton_tagged ("PSINGLE") no_notation points_to_tagged_phys_byte ("P'(_:_:_')") diff --git a/Micro_Rust_Runtime/Shareable_Resource.thy b/Micro_Rust_Runtime/Shareable_Resource.thy index 21a04028..ecc7bd3b 100644 --- a/Micro_Rust_Runtime/Shareable_Resource.thy +++ b/Micro_Rust_Runtime/Shareable_Resource.thy @@ -24,7 +24,7 @@ definition read_shareable_value_core :: \('v shareable_value, 'v, 'r, 'abo )\ definition shareable_value_is :: \share \ 'v \ 'v shareable_value assert\ where - \shareable_value_is sh v \ \0 < sh\ \ \\<^sub>s (Shared_Value (Abs_nonempty_share sh) v)\ + \shareable_value_is sh v \ apure (0 < sh) \ \\<^sub>s (Shared_Value (Abs_nonempty_share sh) v)\ lemma ucincl_shareable_value_is [simp, ucincl_intros]: \ucincl (shareable_value_is sh v)\ unfolding shareable_value_is_def by (simp add: uc_state_ucincl ucincl_intros) @@ -44,8 +44,8 @@ lemma ucincl_shared_value_top[simp, ucincl_intros]: by (simp flip: shareable_value_is_top_alt add: ucincl_intros) lemma asepconj_float_pure: - shows \\ \ \P\ = \P\ \ \\ - and \\ \ \P\ \ \ = \P\ \ \ \ \\ + shows \\ \ apure P = apure P \ \\ + and \\ \ apure P \ \ = apure P \ \ \ \\ by (simp add: asepconj_comm asepconj_swap_top asepconj_pure)+ lemma shareable_value_split: @@ -63,8 +63,9 @@ qed lemma shareable_value_combine: shows \shareable_value_is sh0 v0 \ shareable_value_is sh1 v1 - \ \v0 = v1\ \ \sh0 \ sh1\ \ shareable_value_is (sh0 + sh1) v0\ -proof (intro apure_entailsR apure_entailsR0) + \ \v0 = v1\ \ \sh0 \ sh1\ \ + shareable_value_is (sh0 + sh1) v0\ +proof (intro apure_precise_entailsR) assume "is_sat (shareable_value_is sh0 v0 \ shareable_value_is sh1 v1)" then show "v0 = v1" unfolding shareable_value_is_def @@ -72,7 +73,7 @@ proof (intro apure_entailsR apure_entailsR0) non_is_sat_empty shareable_value_uc_state_asepconj_general) next assume \

: "is_sat (shareable_value_is sh0 v0 \ shareable_value_is sh1 v1)" - then obtain "is_sat \0 < sh1\" "is_sat \0 < sh0\" + then obtain "is_sat (apure (0 < sh1))" "is_sat (apure (0 < sh0))" by (metis is_sat_pure is_sat_splitE shareable_value_is_def) with \
show "sh0 \ sh1" apply (simp add: shareable_value_is_def asepconj_float_pure) @@ -125,14 +126,14 @@ definition read_shareable_value_contract :: \'v \ share \function_contract_abort (read_shareable_value_contract a b) = \\ - by (simp add: read_shareable_value_contract_def pull_back_contract_def) + by (simp add: read_shareable_value_contract_def) lemma read_shareable_value_spec: shows \\; read_shareable_value \\<^sub>F read_shareable_value_contract v sh\ apply (intro satisfies_function_contractI; clarsimp intro!: ucincl_intros simp add: read_shareable_value_contract_def) apply (intro sstripleI; clarsimp simp add: read_shareable_value_def atriple_rel_def - asat_apure_distrib2 ucincl_intros asepconj_simp eval_read_shareable_value_core_local; safe?) + asat_apure_precise_distrib2 ucincl_intros asepconj_simp eval_read_shareable_value_core_local; safe?) apply (auto simp add: eval_read_shareable_value_core shareable_value_is_alt eval_return_def eval_abort_def eval_value_def shareable_value_uc_state asat_def) done @@ -202,7 +203,7 @@ definition write_shareable_value_contract :: \'v \ ('v shareab lemma write_shareable_value_contract_no_abort: shows \function_contract_abort (write_shareable_value_contract a) = \\ - by (simp add: write_shareable_value_contract_def pull_back_contract_def) + by (simp add: write_shareable_value_contract_def) lemma write_shareable_value_spec: shows \\; write_shareable_value v \\<^sub>F write_shareable_value_contract v\ @@ -226,7 +227,7 @@ mechanism to obtain read/write functions on the larger separation algebra:\('s, 'v shareable_value) lens\ -definition resource_is :: \('s, 'v) shareable_resource \ share \ 'v \ 's assert\ +definition resource_is :: \('s::zero, 'v) shareable_resource \ share \ 'v \ 's assert\ where \resource_is l sh v \ l\ (shareable_value_is sh v)\ definition read_resource :: \('s, 'v) shareable_resource \ ('s, 'v, 'abort, 'i, 'o) function_body\ @@ -236,63 +237,83 @@ definition write_resource :: \('s, 'v) shareable_resource\ 'v where \write_resource l v \ l\ (write_shareable_value v)\ definition read_resource_contract :: \('s::sepalg, 'v) shareable_resource \ 'v \ share \ ('s, 'v, 'abort) function_contract\ - where \read_resource_contract l v sh \ l\ (read_shareable_value_contract v sh)\ + where \read_resource_contract l v sh \ + l\ (read_shareable_value_contract v sh)\ lemma read_resource_contract_no_abort: shows \function_contract_abort (read_resource_contract a b c) = \\ - by (simp add: read_shareable_value_contract_no_abort read_resource_contract_def pull_back_contract_def - pull_back_assertion_def bot_fun_def) + by (simp add: read_shareable_value_contract_no_abort read_resource_contract_def + pull_back_contract_def pull_back_assertion_def bot_fun_def) definition write_resource_contract :: \('s::sepalg, 'v) shareable_resource \ 'v \ ('s, unit, 'abort) function_contract\ - where \write_resource_contract l v \ l\ (write_shareable_value_contract v)\ + where \write_resource_contract l v \ + l\ (write_shareable_value_contract v)\ lemma write_resource_contract_no_abort: shows \function_contract_abort (write_resource_contract a b) = \\ - by (simp add: write_shareable_value_contract_no_abort write_resource_contract_def pull_back_contract_def - pull_back_assertion_def bot_fun_def) + by (simp add: write_shareable_value_contract_no_abort write_resource_contract_def + pull_back_contract_def pull_back_assertion_def bot_fun_def) lemma resource_is_split: assumes \is_valid_slens r\ and \sh0 \ sh1\ and \0 < sh0\ and \0 < sh1\ shows \resource_is r (sh0 + sh1) v \ resource_is r sh0 v \ resource_is r sh1 v\ - using assms - apply (clarsimp simp add: resource_is_def shareable_value_split simp flip: slens_pull_back_simps_generic) - apply (simp add: shareable_value_split slens_pull_back_intros_generic) - done +proof - + from assms(2-4) have source: + \shareable_value_is (sh0 + sh1) v \ + shareable_value_is sh0 v \ shareable_value_is sh1 v\ + by (rule shareable_value_split) + from assms(1) source have + \r\ (shareable_value_is (sh0 + sh1) v) \ + r\ (shareable_value_is sh0 v \ shareable_value_is sh1 v)\ + by (rule slens.pull_back_aentailsI[simplified]) + with assms(1) show ?thesis + by (simp add: resource_is_def slens.pull_back_asepconj[simplified]) +qed lemma resource_is_merge: assumes \is_valid_slens r\ - shows \resource_is r sh0 v0 \ resource_is r sh1 v1 \ \sh0 \ sh1\ \ \v0 = v1\ \ resource_is r (sh0 + sh1) v0\ - using assms - apply (clarsimp simp add: resource_is_def shareable_value_split simp flip: slens_pull_back_simps_generic) - apply (metis asepconj_swap_top shareable_value_combine slens_pull_back_intros_generic(2)) - done + shows \resource_is r sh0 v0 \ resource_is r sh1 v1 \ + \sh0 \ sh1\ \ \v0 = v1\ \ + resource_is r (sh0 + sh1) v0\ +proof - + from assms shareable_value_combine have pulled: + \r\ (shareable_value_is sh0 v0 \ shareable_value_is sh1 v1) \ + r\ (\v0 = v1\ \ \sh0 \ sh1\ \ + shareable_value_is (sh0 + sh1) v0)\ + by (rule slens.pull_back_aentailsI[simplified]) + from pulled assms show ?thesis + by (simp add: resource_is_def slens.pull_back_asepconj[simplified] + slens.pull_back_assertion_apure_precise[simplified] asepconj_swap_top) +qed lemma read_resource_spec: assumes \is_valid_slens l\ shows \\; read_resource l \\<^sub>F read_resource_contract l v sh\ - by (simp add: assms slens.pull_back_spec_universal read_resource_contract_def read_resource_def + by (simp add: assms slens.pull_back_spec_universal_precise read_resource_contract_def read_resource_def read_shareable_value_spec read_shareable_value_contract_no_abort) lemma write_resource_spec: assumes \is_valid_slens l\ shows \\; write_resource l v \\<^sub>F write_resource_contract l v\ - by (simp add: assms slens.pull_back_spec_universal write_resource_contract_def write_resource_def + by (simp add: assms slens.pull_back_spec_universal_precise write_resource_contract_def write_resource_def write_shareable_value_spec write_shareable_value_contract_no_abort) lemma resource_is_eval_lens_alt: shows \\ \ resource_is (share_map_eval_lens k) sh v - \ 0 < sh \ Shared_Value (Abs_nonempty_share sh) v \ rbt_share_map_\ \ k\ - by (clarsimp simp add: share_map_eval_lens_def resource_is_def pull_back_assertion_def asat_def - shareable_value_is_alt uc_state_def) + \ 0 < sh \ Shared_Value (Abs_nonempty_share sh) v \ rbt_share_map_\ \ k + \ \ = lens_update (share_map_eval_lens k) (rbt_share_map_\ \ k) 0\ + by (auto simp add: share_map_eval_lens_def resource_is_def pull_back_assertion_def + asat_def shareable_value_is_alt uc_state_def) lemma rbt_share_map_decompose_resource: fixes m :: \('k::linorder, 'v) rbt_share_map\ shows \m \ \\{# resource_is (share_map_eval_lens k) (Rep_nonempty_share sh) v . (k, v, sh) \ rbt_share_map_mset m #}\ using Rep_nonempty_share by (auto intro!: rbt_share_map_decompose_generic - simp add: resource_is_eval_lens_alt zero_share_def Rep_nonempty_share_inverse) + simp add: resource_is_eval_lens_alt zero_share_def Rep_nonempty_share_inverse + rbt_share_map_singleton_def) (simp add: share_map_eval_lens_def) subsection\Construction RW resources from \<^verbatim>\shareable_value\\ @@ -306,7 +327,7 @@ code generator to replace it with an error instead. Note that \<^verbatim>\\l\ on the LHS of its defining equation, so won't be invoked.\ declare [[code abort: resource_is]] -definition rw_resource_from_slens :: \('s, 'v) shareable_resource \ ('s, 'v, 'abort, 'i, 'o) rw_resource\ where +definition rw_resource_from_slens :: \('s::zero, 'v) shareable_resource \ ('s, 'v, 'abort, 'i, 'o) rw_resource\ where \rw_resource_from_slens l \ make_rw_resource (resource_is l) (read_resource l) (write_resource l)\ lemma rw_resource_from_slens_contracts: @@ -315,11 +336,15 @@ lemma rw_resource_from_slens_contracts: = read_resource_contract l\ and \generic_write_contract (rw_resource_is (rw_resource_from_slens l)) = write_resource_contract l\ - using assms by (auto intro!: ext simp add: generic_write_contract_def generic_read_contract_def - rw_resource_is_def rw_resource_from_slens_def resource_is_def - read_resource_contract_def read_shareable_value_contract_def + using valid by (auto intro!: ext simp add: generic_write_contract_def + generic_read_contract_def rw_resource_is_def rw_resource_from_slens_def + resource_is_def read_resource_contract_def read_shareable_value_contract_def write_resource_contract_def write_shareable_value_contract_def - pull_back_contract_def slens_pull_back_simps_generic) + pull_back_contract_def + slens.pull_back_asepconj[simplified] + slens.pull_back_assertion_apure_precise[simplified] + slens.pull_back_assertion_false[simplified] + slens.pull_back_assert_Union[simplified]) \\NOTE: This lemma is not used at present, but seems worth keeping.\ lemma read_resource_contract_concrete: @@ -332,17 +357,14 @@ lemma rw_resource_valid: assumes \is_valid_slens l\ shows \standard_rw_resource (rw_resource_from_slens l)\ proof (intro standard_rw_resourceI) - fix sh v show \ucincl (rw_resource_is (rw_resource_from_slens l) sh v)\ - by (simp add: assms resource_is_def rw_resource_from_slens_def slens.pull_back_ucincl) -next fix sh0 sh1 :: share and v0 v1 from assms show \rw_resource_is (rw_resource_from_slens l) sh0 v0 \ rw_resource_is (rw_resource_from_slens l) sh1 v1 - \ \sh0 \ sh1\ \ \v0 = v1\ \ rw_resource_is (rw_resource_from_slens l) (sh0 + sh1) v0\ + \ \sh0 \ sh1\ \ \v0 = v1\ \ + rw_resource_is (rw_resource_from_slens l) (sh0 + sh1) v0\ by (clarsimp simp add: resource_is_merge rw_resource_from_slens_def) next - fix sh0 sh1 :: share and v fix sh0 sh1 :: share and v assume \0 < sh0\ and \0 < sh1\ and \sh0 \ sh1\ from this and assms show @@ -365,8 +387,9 @@ qed lemma rw_resource_is_from_slens: assumes \is_valid_slens l\ - shows \\ \ rw_resource_is (rw_resource_from_slens l) \ x \ lens_view l \ = Shared_Value \ x\ + shows \\ \ rw_resource_is (rw_resource_from_slens l) \ x + \ \ = lens_update l (Shared_Value \ x) 0\ by (clarsimp simp add: rw_resource_from_slens_def asat_def resource_is_def pull_back_assertion_def shareable_value_is_top_alt) -end \ No newline at end of file +end diff --git a/Micro_Rust_Std_Lib/StdLib_Arithmetic.thy b/Micro_Rust_Std_Lib/StdLib_Arithmetic.thy index 7e292356..438e5761 100644 --- a/Micro_Rust_Std_Lib/StdLib_Arithmetic.thy +++ b/Micro_Rust_Std_Lib/StdLib_Arithmetic.thy @@ -51,10 +51,9 @@ definition div_ceil :: \'a::{len} word \ 'a word \ definition overflowing_mul_contract :: \'l::{len} word \ 'l word \ ('machine::{sepalg}, 'l word \ bool \ tnil, 'b) function_contract\ where [crush_contracts]: \overflowing_mul_contract x y \ - let pre = \True\ in \ \Any inputs are acceptable\ - let post = \ret. \ret = (x * y, unat x * unat y \ 2^LENGTH('l), TNil)\ in \ \The specification is not different from the function body\ + let pre = emp in \ \Any inputs are acceptable, and no resource is needed\ + let post = \ret. \ret = (x * y, unat x * unat y \ 2^LENGTH('l), TNil)\ in make_function_contract pre post\ -ucincl_auto overflowing_mul_contract lemma overflowing_mul_spec [crush_specs]: shows \\ ; overflowing_mul x y \\<^sub>F overflowing_mul_contract x y\ @@ -63,10 +62,9 @@ by (crush_boot f: overflowing_mul_def contract: overflowing_mul_contract_def) cr definition overflowing_add_contract :: \'l::{len} word \ 'l word \ ('machine::{sepalg}, 'l word \ bool \ tnil, 'b) function_contract\where [crush_contracts]: \overflowing_add_contract x y \ - let pre = \True\ in + let pre = emp in let post = \ret. \ret = (x + y, unat x + unat y \ 2^LENGTH('l), TNil)\ in make_function_contract pre post\ -ucincl_auto overflowing_add_contract lemma overflowing_add_spec [crush_specs]: shows \\ ; overflowing_add x y \\<^sub>F overflowing_add_contract x y\ @@ -75,10 +73,9 @@ by (crush_boot f: overflowing_add_def contract: overflowing_add_contract_def) cr definition wrapping_add_unsigned_contract :: \'l::{len} word \ 'l word \ ('machine::{sepalg}, 'l word, 'b) function_contract\ where [crush_contracts]: \wrapping_add_unsigned_contract x y \ - let pre = \True\ in + let pre = emp in let post = \ret. \ret = x + y\ in make_function_contract pre post\ -ucincl_auto wrapping_add_unsigned_contract lemma wrapping_add_unsigned_spec [crush_specs]: shows \\ ; wrapping_add_unsigned x y \\<^sub>F wrapping_add_unsigned_contract x y\ @@ -87,10 +84,9 @@ by (crush_boot f: wrapping_add_unsigned_def contract: wrapping_add_unsigned_cont definition saturating_sub_contract :: \'l::{len} word \ 'l word \ ('machine::{sepalg}, 'l word, 'b) function_contract\ where [crush_contracts]: \saturating_sub_contract x y \ - let pre = \True\ in + let pre = emp in let post = \ret. \ret = (if x < y then 0 else x - y)\ in make_function_contract pre post\ -ucincl_auto saturating_sub_contract lemma saturating_sub_spec [crush_specs]: shows \\ ; saturating_sub x y \\<^sub>F saturating_sub_contract x y\ @@ -99,10 +95,9 @@ by (crush_boot f: saturating_sub_def contract: saturating_sub_contract_def) definition div_ceil_contract :: \'l::{len} word \ 'l word \ ('machine::{sepalg}, 'l word, 'b) function_contract\ where [crush_contracts]: \div_ceil_contract x y \ - let pre = \; + let pre = emp; post = \ret. \ret = (x + y - 1) div y\ in make_function_contract pre post\ -ucincl_auto div_ceil_contract lemma div_ceil_spec [crush_specs]: shows \\ ; div_ceil x y \\<^sub>F div_ceil_contract x y\ @@ -131,10 +126,9 @@ micro_rust_notation (call) nonzerou64_new ("NonZeroU64::new") definition nonzerou64_new_contract :: \64 word \ ('machine::{sepalg}, nonzero_u64 option, 'b) function_contract\ where [crush_contracts]: \nonzerou64_new_contract n \ - let pre = \; + let pre = emp; post = \res. \res = nonzerou64_new_core n\ in make_function_contract pre post\ -ucincl_auto nonzerou64_new_contract lemma nonzerou64_new_spec [crush_specs]: shows \\ ; nonzerou64_new n \\<^sub>F nonzerou64_new_contract n\ @@ -145,18 +139,14 @@ definition nonzerou64_get :: \nonzero_u64 \ ('machine, 64 word definition nonzerou64_get_contract :: \nonzero_u64 \ ('machine::{sepalg}, 64 word, 'b) function_contract\ where [crush_contracts]: \nonzerou64_get_contract nz \ - let pre = \; + let pre = emp; post = \res. \res = nonzero_u64_project nz\ in make_function_contract pre post\ -ucincl_auto nonzerou64_get_contract lemma nonzero_u64_get_spec [crush_specs]: shows \\ ; nonzerou64_get nz \\<^sub>F nonzerou64_get_contract nz\ - apply (crush_boot f: nonzerou64_get_def contract: nonzerou64_get_contract_def) - apply (cases nz) - apply (simp add: aentails_refl asepconj_False_True(2) asepconj_UNIV_idempotent wp_literalI) - done +by (crush_boot f: nonzerou64_get_def contract: nonzerou64_get_contract_def) crush_base (*<*) end -(*>*) \ No newline at end of file +(*>*) diff --git a/Micro_Rust_Std_Lib/StdLib_Contracts.thy b/Micro_Rust_Std_Lib/StdLib_Contracts.thy index 9ec0984a..a884adbc 100644 --- a/Micro_Rust_Std_Lib/StdLib_Contracts.thy +++ b/Micro_Rust_Std_Lib/StdLib_Contracts.thy @@ -14,11 +14,16 @@ The main use case is for proving weakening rules: In this case, the base contract is passed to \<^verbatim>\crush\ to discharge \<^verbatim>\call f\, and the locality is typically a direct consequence of weakening. See the examples below.\ +text\Result-case post-conditions are upwards closed when both branches are, allowing +\<^verbatim>\ucincl_solve\ to discharge fallible specifications:\ +lemma ucincl_case_result [ucincl_intros]: + assumes \\x. ucincl (f x)\ + and \\e. ucincl (g e)\ + shows \ucincl (case_result f g r)\ + using assms by (cases r; simp) + lemma satisfies_function_contract_via_call: - assumes U0: \ucincl (function_contract_pre \)\ - and U1: \\r. ucincl (function_contract_post \ r)\ - and U2: \\r. ucincl (function_contract_abort \ r)\ - and LOC: \urust_is_local (yh \) (function_body f) (function_contract_pre \)\ + assumes LOC: \urust_is_local (yh \) (function_body f) (function_contract_pre \)\ and W: \function_contract_pre \ \ \\

\ (call f) (function_contract_post \) (function_contract_post \) (function_contract_abort \)\ @@ -35,66 +40,84 @@ proof - from this and LOC have \\ ; function_contract_pre \ \ (function_body f) \ function_contract_post \ \ function_contract_post \ \ function_contract_abort \\ by (simp add: sstriple_striple eval_abort_def eval_return_def eval_value_def) - from this and U0 U1 U2 show ?thesis + from this show ?thesis by (intro satisfies_function_contractI; simp) qed lemma satisfies_function_contract_weaken: assumes C: \\ ; f \\<^sub>F \\ - and \ucincl (function_contract_pre \')\ - and \\r. ucincl (function_contract_post \' r)\ - and \\r. ucincl (function_contract_abort \' r)\ and PRE: \function_contract_pre \' \ function_contract_pre \\ and \\r. function_contract_post \ r \ function_contract_post \' r\ and \\r. function_contract_abort \ r \ function_contract_abort \' r\ shows \\ ; f \\<^sub>F \'\ - using assms - apply (elim satisfies_function_contractE', intro satisfies_function_contract_via_call; - simp add: sstriple_implies_is_local urust_is_local_weaken[OF PRE]) - apply (crush_base specs add: C seplog drule add: PRE) - done +proof (intro satisfies_function_contractI) + show \\ ; function_contract_pre \' \ function_body f + \ function_contract_post \' \ function_contract_post \' + \ function_contract_abort \'\ + by (rule sstriple_consequence[OF satisfies_function_contract_tripleD'[OF C]]) + (use assms in auto) +qed lemma satisfies_function_contract_weaken_wp: assumes C: \\ ; f \\<^sub>F \\ - and U0: \ucincl (function_contract_pre \')\ - and U1: \\r. ucincl (function_contract_post \' r)\ - and U2: \\r. ucincl (function_contract_abort \' r)\ and PRE: \function_contract_pre \' \ function_contract_pre \ \ ((\r. function_contract_post \ r \ function_contract_post \' r) \ ((\r. function_contract_abort \ r \ function_contract_abort \' r)))\ shows \\ ; f \\<^sub>F \'\ proof - - from PRE and C have - PRE': \function_contract_pre \' \ function_contract_pre \\ - using aentails_cancel_r aentails_trans' satisfies_function_contractE' by blast - from C PRE' U0 U1 U2 show ?thesis - apply (elim satisfies_function_contractE', intro satisfies_function_contract_via_call; - simp add: sstriple_implies_is_local urust_is_local_weaken[OF PRE']) - apply (crush_base specs add: C seplog drule add: PRE) - done + let ?frame = \((\r. function_contract_post \ r \ function_contract_post \' r) + \ (\r. function_contract_abort \ r \ function_contract_abort \' r))\ + have framed: \\ ; function_contract_pre \ \ ?frame \ function_body f + \ (\r. function_contract_post \ r \ ?frame) + \ (\r. function_contract_post \ r \ ?frame) + \ (\r. function_contract_abort \ r \ ?frame)\ + by (rule sstriple_frame_rule[OF satisfies_function_contract_tripleD'[OF C]]) + \\The frame stores the post- and abort-wands consumed by + \<^verbatim>\awand_forall_inter_counit\.\ + have post: \\r. function_contract_post \ r \ ?frame + \ function_contract_post \' r\ + by (rule awand_forall_inter_counit) + have abort: \\r. function_contract_abort \ r \ ?frame + \ function_contract_abort \' r\ + by (rule awand_forall_inter_counit) + show ?thesis + by (intro satisfies_function_contractI sstriple_consequence[OF framed PRE post post abort]) qed lemma satisfies_function_contract_weaken_wp_lambda: assumes C: \\x. \ ; f \\<^sub>F \ x\ - and U0: \ucincl (function_contract_pre \')\ - and U1: \\r. ucincl (function_contract_post \' r)\ - and U2: \\r. ucincl (function_contract_abort \' r)\ and PRE: \function_contract_pre \' \ (\x. function_contract_pre (\ x) \ ((\r. function_contract_post (\ x) r \ function_contract_post \' r) \ (\r. function_contract_abort (\ x) r \ function_contract_abort \' r)))\ shows \\ ; f \\<^sub>F \'\ proof - - from PRE and C have PRE': \function_contract_pre \' \ (\x. function_contract_pre (\ x))\ - by (meson aentails_cancel_r aentails_trans aexists_entailsL aexists_entailsR - satisfies_function_contractE') - have \urust_is_local (yh \) (function_body f) (function_contract_pre \')\ - using urust_is_local_weaken[OF PRE'] urust_is_local_Union function_contract_implies_is_local[OF C] - by metis - from this and U0 U1 U2 show ?thesis - apply (intro satisfies_function_contract_via_call; simp add: function_contract_implies_is_local - urust_is_local_weaken urust_is_local_Union) - apply (crush_base specs add: C seplog drule add: PRE) - done + let ?frame = \\x. ((\r. function_contract_post (\ x) r \ function_contract_post \' r) + \ (\r. function_contract_abort (\ x) r \ function_contract_abort \' r))\ + have framed: \\ ; function_contract_pre (\ x) \ ?frame x \ function_body f + \ function_contract_post \' \ function_contract_post \' + \ function_contract_abort \'\ for x + proof - + have base: \\ ; function_contract_pre (\ x) \ ?frame x \ function_body f + \ (\r. function_contract_post (\ x) r \ ?frame x) + \ (\r. function_contract_post (\ x) r \ ?frame x) + \ (\r. function_contract_abort (\ x) r \ ?frame x)\ + by (rule sstriple_frame_rule[OF satisfies_function_contract_tripleD'[OF C]]) + have post: \\r. function_contract_post (\ x) r \ ?frame x + \ function_contract_post \' r\ + by (rule awand_forall_inter_counit) + have abort: \\r. function_contract_abort (\ x) r \ ?frame x + \ function_contract_abort \' r\ + by (rule awand_forall_inter_counit) + show ?thesis + by (rule sstriple_consequence[OF base aentails_refl post post abort]) + qed + have union: \\ ; (\x. function_contract_pre (\ x) \ ?frame x) + \ function_body f \ function_contract_post \' + \ function_contract_post \' \ function_contract_abort \'\ + by (rule sstriple_existsI) (rule framed) + show ?thesis + by (intro satisfies_function_contractI sstriple_consequence[OF union PRE]; + rule aentails_refl) qed lemma Union_split: \(\(x :: 'a \ 'b). P x) = (\(x::'a). \(y :: 'b). P (x,y))\ by force @@ -146,17 +169,11 @@ lemmas satisfies_function_contract_weaken_wp_lambda_many = lemma satisfies_function_contract_assume_precondition: assumes \is_sat (function_contract_pre \) \ (\ ; f \\<^sub>F \)\ - and \ucincl (function_contract_pre \)\ - and \\r. ucincl (function_contract_post \ r)\ - and \\r. ucincl (function_contract_abort \ r)\ shows \\ ; f \\<^sub>F \\ using assms by (metis sstriple_assume_is_sat satisfies_function_contractI) - lemma satisfies_function_contract_weaken': assumes \\ ; f \\<^sub>F \\ - and \ucincl (function_contract_pre \')\ - and \\r. ucincl (function_contract_post \' r)\ - and \\r. ucincl (function_contract_abort \' r)\ and \function_contract_pre \' \ function_contract_pre \\ and \\r. is_sat (function_contract_pre \') \ function_contract_post \ r \ function_contract_post \' r\ @@ -171,4 +188,4 @@ using assms (*<*) end -(*>*) \ No newline at end of file +(*>*) diff --git a/Micro_Rust_Std_Lib/StdLib_Iterators.thy b/Micro_Rust_Std_Lib/StdLib_Iterators.thy index cc6f4f43..41fdf955 100644 --- a/Micro_Rust_Std_Lib/StdLib_Iterators.thy +++ b/Micro_Rust_Std_Lib/StdLib_Iterators.thy @@ -81,10 +81,8 @@ definition iterator_find_contract :: \'a list \ ('a \\ i. \; pred_rust i \\<^sub>F lift_pure_to_contract (pred_pure i)\ in let post = \ ret. \ret = List.find pred_pure vs\ in make_function_contract pre post\ -ucincl_auto iterator_find_contract declare lift_pure_to_contract_def [crush_contracts] -ucincl_auto lift_pure_to_contract lemma iterator_find_spec: shows \\ ; StdLib_Iterators.find (make_iterator_from_list vs) pred_rust \\<^sub>F iterator_find_contract vs pred_pure \ pred_rust\ diff --git a/Micro_Rust_Std_Lib/StdLib_Option.thy b/Micro_Rust_Std_Lib/StdLib_Option.thy index 65892faa..57d80845 100644 --- a/Micro_Rust_Std_Lib/StdLib_Option.thy +++ b/Micro_Rust_Std_Lib/StdLib_Option.thy @@ -22,7 +22,6 @@ definition option_expect_contract :: \'a option \ String.liter let pre = \opt \ None\; post = \r. \r = the opt\ in make_function_contract pre post\ -ucincl_auto option_expect_contract lemma option_expect_spec [crush_specs]: shows \\; option_expect res m \\<^sub>F option_expect_contract res v\ @@ -40,7 +39,6 @@ definition option_unwrap_contract :: where [crush_contracts]: \option_unwrap_contract self v \ let pre = \self = Some v\; post = \r. \r = v\ in make_function_contract pre post\ -ucincl_auto option_unwrap_contract lemma option_unwrap_spec [crush_specs]: shows \\; option_unwrap res \\<^sub>F option_unwrap_contract res v\ @@ -59,9 +57,8 @@ micro_rust_notation (call) urust_func_option_is_none ("is_none") definition option_is_none_contract :: \'a option \ ('s::{sepalg}, bool, 'abort) function_contract\ where [crush_contracts]: \option_is_none_contract res \ - let pre = UNIV; post = \r. \r = Option.is_none res\ + let pre = emp; post = \r. \r = Option.is_none res\ in make_function_contract pre post\ -ucincl_auto option_is_none_contract lemma option_is_none_spec [crush_specs]: shows \\; urust_func_option_is_none res \\<^sub>F option_is_none_contract res\ @@ -80,10 +77,9 @@ micro_rust_notation (call) urust_func_option_is_some ("is_some") definition option_is_some_contract :: \'a option \ ('s::{sepalg}, bool, 'abort) function_contract\ where [crush_contracts]: \option_is_some_contract res \ - let pre = UNIV; + let pre = emp; post = \r. \r \ \Option.is_none res\ in make_function_contract pre post\ -ucincl_auto option_is_some_contract lemma option_is_some_spec [crush_specs]: shows \\; urust_func_option_is_some res \\<^sub>F option_is_some_contract res\ @@ -108,10 +104,9 @@ by (auto simp add: ok_or_pure_def) definition option_ok_or_contract :: \'v option \ 'e \ ('s::{sepalg}, ('v, 'e) result, 'abort) function_contract\ where [crush_contracts]: \option_ok_or_contract opt e \ - let pre = UNIV; + let pre = emp; post = \r. \r = ok_or_pure opt e\ in make_function_contract pre post\ -ucincl_auto option_ok_or_contract lemma option_ok_or_spec [crush_specs]: shows \\; ok_or opt e \\<^sub>F option_ok_or_contract opt e\ @@ -140,7 +135,6 @@ definition option_as_mut_contract :: \'b \ ('a, 'b, 'v option) post = \res. ref \\\\ g\opt \ \res = (if opt = None then None else Some (focus_option ref))\ in make_function_contract pre post\ -ucincl_auto option_as_mut_contract lemma option_as_mut_spec [crush_specs]: shows \\; option_as_mut ref \\<^sub>F option_as_mut_contract g ref opt\ @@ -163,7 +157,6 @@ definition take_mut_ref_option_contract :: \('a, 'b, 'v option) Global_Sto let pre = ptr \\\\ g\v; post = \r. (\r=v\ \ ptr \\\\ (\_. None)\(g\v)) in make_function_contract pre post\ -ucincl_auto take_mut_ref_option_contract lemma take_mut_ref_option_spec[crush_specs]: shows \\; take_mut_ref_option ptr \\<^sub>F take_mut_ref_option_contract ptr g v\ diff --git a/Micro_Rust_Std_Lib/StdLib_Range.thy b/Micro_Rust_Std_Lib/StdLib_Range.thy index 080c6e8c..0d61535e 100644 --- a/Micro_Rust_Std_Lib/StdLib_Range.thy +++ b/Micro_Rust_Std_Lib/StdLib_Range.thy @@ -9,11 +9,10 @@ begin definition is_empty_contract :: \'a::{ord} range \ ('machine::{sepalg}, bool, 'abort) function_contract\ where [crush_contracts]: \is_empty_contract r \ - let pre = \; + let pre = emp; post = \res. \res \ (if end_inclusive r then start r > end r else \start r < end r)\ in make_function_contract pre post\ -ucincl_auto is_empty_contract lemma is_empty_spec [crush_specs]: shows \\ ; is_empty r \\<^sub>F is_empty_contract r\ @@ -21,11 +20,10 @@ by (contract f: is_empty_def contract: is_empty_contract_def) crush_base definition contains_contract :: \'a::{ord} range \ 'a \ ('machine::{sepalg}, bool, 'abort) function_contract\ where [crush_contracts]: \contains_contract r e \ - let pre = \; + let pre = emp; post = \res. \res \ (if end_inclusive r then start r \ e \ e \ end r else start r \ e \ e < end r)\ in make_function_contract pre post\ -ucincl_auto contains_contract lemma contains_spec [crush_specs]: shows \\ ; contains r e \\<^sub>F contains_contract r e\ diff --git a/Micro_Rust_Std_Lib/StdLib_References.thy b/Micro_Rust_Std_Lib/StdLib_References.thy index 4346c101..7452ae5f 100644 --- a/Micro_Rust_Std_Lib/StdLib_References.thy +++ b/Micro_Rust_Std_Lib/StdLib_References.thy @@ -19,10 +19,8 @@ named_theorems crush_points_to_cond_crules declare points_to_aentails [crush_points_to_crules] -(* Custom rules for working with the points-to predicates. - * - * Those are currently only gathered in the above named theorem lists, - * but not applied by crush by default. *) +(* Optional points-to conversions are kept in dedicated collections. + * Rules safe for generic entailment automation are registered below. *) lemma points_to_aentails_crule[crush_aentails_cond_crules]: shows \r \\sh\ g0\v0 [ @@ -34,11 +32,14 @@ lemma points_to_aentails_crule[crush_aentails_cond_crules]: unfolding aentails_conditional_crule_strong_def by (crush_base simp add: points_to_def) -lemma points_to_aentails_crule_focusedL[crush_points_to_cond_crules]: +lemma points_to_aentails_crule_focusedL[ + crush_points_to_cond_crules, + crush_aentails_cond_crules + ]: shows \focus_reference f r \\sh\ g1\v1 [ - \g0 = g1\ - \ \focus_view f v0 = Some v1\ + \g0 = g1\ + \ \focus_view f v0 = Some v1\ \ \points_to_localizes r g0 v0\ ]\\<^sub>s[ \points_to_localizes (focus_reference f r) g1 v1\ @@ -60,6 +61,16 @@ lemma points_to_aentails_crule_focusedR[crush_aentails_cond_crules]: unfolding aentails_conditional_crule_strong_def by (crush_base simp add: points_to_def) +text\Generic entailment automation converts focused ownership to its +parent reference without the legacy points-to tactic.\ +lemma points_to_focusedL_crush_test: + assumes \focus_view f v = Some w\ + and \points_to_localizes r g v\ + shows \focus_reference f r \\sh\ g\w + \ r \\sh\ g\v\ + supply [[crush_enable_legacy_points_to_tactic = false]] + using assms by crush_base + (* declare crush_points_to_crules[crush_aentails_crules] declare crush_points_to_cond_crules[crush_aentails_cond_crules] @@ -78,10 +89,10 @@ using assms done lemma points_to_combine: - shows \r \\sh1\ g1\v1 \ r \\sh2\ g2\v2 \ r \\sh1+sh2\ g1\v1 \ \g1 = g2\ \ \v1 = v2\\ - apply (crush_base simp [prems, concls] add: points_to_def seplog drule add: points_to_raw_combine) - apply (simp add: aentails_def plus_share_def sup_aci(1)) - done + shows \r \\sh1\ g1\v1 \ r \\sh2\ g2\v2 + \ r \\sh1+sh2\ g1\v1 \ \g1 = g2\ \ \v1 = v2\\ + by (crush_base simp [prems, concls] add: points_to_def seplog drule + add: points_to_raw_combine[where ?sh1.0=sh1]) lemma focus_compose_valid_dropE[focus_elims]: assumes \is_valid_ref_for (focus_reference r l) P\ @@ -121,10 +132,6 @@ lemma focus_is_view_modify_partial_guarded: shows \focus_is_view f0 (focus_modify (f0' \ f1) op x) y\ using assms unfolding GUARD_def by (simp add: focus_is_view_modify_partial) -ucincl_auto points_to update_raw_contract dereference_raw_contract reference_raw_contract - update_contract modify_raw_contract modify_contract dereference_contract - ro_dereference_contract reference_contract - declare update_raw_spec[crush_specs] declare dereference_raw_spec[crush_specs] declare reference_raw_spec[crush_specs] @@ -223,12 +230,10 @@ definition transpose_contract :: \(('a, 'b) ro_gref, 'b, 't option) focuse \ ref \ \\\ g\v_opt in make_function_contract pre post\ -ucincl_auto transpose_contract - lemma transpose_spec[crush_specs]: shows \\ ; transpose ro_ref \\<^sub>F transpose_contract ro_ref g v_opt\ - by (crush_boot f: transpose_def contract: transpose_contract_def) - (crush_base simp add: ro_ref_from_ref_def unsafe_ref_from_ro_ref_def + apply (crush_boot f: transpose_def contract: transpose_contract_def) + by (crush_base simp add: ro_ref_from_ref_def unsafe_ref_from_ro_ref_def intro!: focused.expand split!: ro_gref.splits option.splits) lemma prism_compose_allocatable: @@ -318,7 +323,6 @@ definition ref_test_contract where let pre = can_alloc_reference in let post = \r. can_alloc_reference \ \r = 12\ in make_function_contract pre post\ -ucincl_auto ref_test_contract lemma ref_test_spec: shows \\; ref_test \\<^sub>F ref_test_contract\ diff --git a/Micro_Rust_Std_Lib/StdLib_Result.thy b/Micro_Rust_Std_Lib/StdLib_Result.thy index 4cfbe064..d1a87fb9 100644 --- a/Micro_Rust_Std_Lib/StdLib_Result.thy +++ b/Micro_Rust_Std_Lib/StdLib_Result.thy @@ -25,7 +25,6 @@ definition result_expect_contract :: where [crush_contracts]: \result_expect_contract self v \ let pre = \self = Ok v\; post = \r. \r = v\ in make_function_contract pre post\ -ucincl_auto result_expect_contract lemma result_expect_spec [crush_specs]: shows \\; result_expect res m \\<^sub>F result_expect_contract res v\ @@ -44,7 +43,6 @@ definition result_unwrap_contract :: where [crush_contracts]: \result_unwrap_contract self v \ let pre = \self = Ok v\; post = \r. \r = v\ in make_function_contract pre post\ -ucincl_auto result_unwrap_contract lemma result_unwrap_spec [crush_specs]: shows \\; result_unwrap res \\<^sub>F result_unwrap_contract res v\ @@ -64,9 +62,8 @@ micro_rust_notation (call) urust_func_result_is_err ("is_err") definition result_is_err_contract :: \('a, 'e) result \ ('s::{sepalg}, bool, 'abort) function_contract\ where [crush_contracts]: \result_is_err_contract res \ - let pre = UNIV; post = \r. \r = result_is_err res\ + let pre = emp; post = \r. \r = result_is_err res\ in make_function_contract pre post\ -ucincl_auto result_is_err_contract lemma result_is_err_spec [crush_specs]: shows \\; urust_func_result_is_err res \\<^sub>F result_is_err_contract res\ @@ -86,9 +83,8 @@ micro_rust_notation (call) urust_func_result_is_ok ("is_ok") definition result_is_ok_contract :: \('a, 'e) result \ ('s::{sepalg}, bool, 'abort) function_contract\ where [crush_contracts]: \result_is_ok_contract res \ - let pre = UNIV; post = \r. \r = result_is_ok res\ + let pre = emp; post = \r. \r = result_is_ok res\ in make_function_contract pre post\ -ucincl_auto result_is_ok_contract lemma result_is_ok_spec [crush_specs]: shows \\; urust_func_result_is_ok res \\<^sub>F result_is_ok_contract res\ @@ -115,9 +111,8 @@ lemma result_or_pure_simps[simp]: definition result_or_contract :: \('a, 'e) result \ ('a, 'f) result \ ('s::{sepalg}, ('a, 'f) result, 'abort) function_contract\ where [crush_contracts]: \result_or_contract res if_err \ - let pre = UNIV; post = \r. \r = result_or_pure res if_err\ + let pre = emp; post = \r. \r = result_or_pure res if_err\ in make_function_contract pre post\ -ucincl_auto result_or_contract lemma result_or_spec [crush_specs]: shows \\; result_or res if_err \\<^sub>F result_or_contract res if_err\ @@ -143,10 +138,9 @@ definition ok :: \('v, 'e) result \ ('s, 'v option, 'abort, 'i definition ok_contract :: \('v, 'e) result \ ('s::{sepalg}, 'v option, 'abort) function_contract\ where [crush_contracts]: \ok_contract res \ - let pre = UNIV; + let pre = emp; post = \r. \r = (case res of Err(_) \ None | Ok(k) \ Some k)\ in make_function_contract pre post\ -ucincl_auto ok_contract lemma ok_spec [crush_specs]: shows \\; ok res \\<^sub>F ok_contract res\ @@ -187,7 +181,6 @@ definition result_as_mut_contract :: \'b \ ('a, 'b, ('v, 'e) r else Err (focus_result_err ref))\ in make_function_contract pre post\ -ucincl_auto result_as_mut_contract lemma result_as_mut_spec [crush_specs]: shows \\; result_as_mut ref \\<^sub>F result_as_mut_contract g ref opt\ diff --git a/Micro_Rust_Std_Lib/StdLib_Slice.thy b/Micro_Rust_Std_Lib/StdLib_Slice.thy index ade35c0a..6bbe4276 100644 --- a/Micro_Rust_Std_Lib/StdLib_Slice.thy +++ b/Micro_Rust_Std_Lib/StdLib_Slice.thy @@ -9,10 +9,9 @@ begin definition range_new_contract :: \'a \ 'a \ ('s::sepalg, 'a range, 'abort) function_contract\ where [crush_contracts]: \range_new_contract b e \ - let pre = \True\; + let pre = emp; post = \r. \r = make_range b e False\ in make_function_contract pre post\ -ucincl_auto range_new_contract lemma range_new_spec [crush_specs]: shows \\ ; range_new b e \\<^sub>F range_new_contract b e\ @@ -25,7 +24,6 @@ definition list_index_contract where [crush_contracts]: let pre = \unat idx < length lst\ in let post = \r. \r = lst ! (unat idx)\ in make_function_contract pre post\ -ucincl_auto list_index_contract lemma list_index_spec [crush_specs]: shows \\ ; list_index lst idx \\<^sub>F list_index_contract lst idx\ @@ -38,7 +36,6 @@ definition array_index_contract where [crush_contracts]: let pre = \unat idx < LENGTH('l)\ in let post = \r. \r = array_nth lst (unat idx)\ in make_function_contract pre post\ -ucincl_auto array_index_contract lemma array_index_spec [crush_specs]: shows \\ ; array_index lst idx \\<^sub>F array_index_contract lst idx\ @@ -63,7 +60,6 @@ definition slice_index_contract :: \(('a, 'b) gref, 'b, 'c list) focused \ \unat idx < length ls\ in let post = \r. (ptr \\sh\ g\ls \ \r = focus_nth (unat idx) ptr\) in make_function_contract pre post\ -ucincl_auto slice_index_contract lemma slice_index_spec [crush_specs]: shows \\ ; slice_index ptr idx \\<^sub>F slice_index_contract ptr g ls idx sh\ @@ -86,7 +82,6 @@ definition slice_index_array_contract :: \(('a, 'b) gref, 'b, ('t, 'l::{le \unat idx < LENGTH('l)\ in let post = \r. (ptr \\sh\ g\ls \ \r = focus_nth_array (unat idx) ptr\) in make_function_contract pre post\ -ucincl_auto slice_index_array_contract lemma slice_index_array_spec [crush_specs]: shows \\ ; slice_index_array ptr idx \\<^sub>F slice_index_array_contract ptr g ls idx sh\ @@ -111,7 +106,6 @@ definition slice_index_vector_contract :: \(('a, 'b) gref, 'b, ('t, 'l::{l \unat idx < vector_len ls\ in let post = \r. (ptr \\sh\ g\ls \ \r = focus_nth_vector (unat idx) ptr\) in make_function_contract pre post\ -ucincl_auto slice_index_vector_contract lemma slice_index_vector_spec [crush_specs]: shows \\ ; slice_index_vector ptr idx \\<^sub>F slice_index_vector_contract ptr g ls idx sh\ @@ -159,7 +153,6 @@ definition list_index_range_contract :: \'t list \ 'w::{len} w res = List.take (unat (end r) - unat (start r)) (List.drop (unat (start r)) xs))\ in make_function_contract pre post\ -ucincl_auto list_index_range_contract lemma list_index_range_spec [crush_specs]: shows \\ ; list_index_range xs r \\<^sub>F list_index_range_contract xs r\ diff --git a/Separation_Lenses/SLens_Pullback.thy b/Separation_Lenses/SLens_Pullback.thy index 65693156..c8e5f7d0 100644 --- a/Separation_Lenses/SLens_Pullback.thy +++ b/Separation_Lenses/SLens_Pullback.thy @@ -23,13 +23,52 @@ as a separation algebra implementing \<^emph>\both\ \<^verbatim>\ -definition pull_back_assertion :: \('s, 't) lens \ 't assert \ 's assert\ - where \pull_back_assertion l \ = {\. lens_view l \ \ \}\ +text\Assertion pullbacks differ in how they account for the lens complement. The precise +pullback embeds a satisfying viewed state into an empty complement and therefore preserves exact +ownership; it receives the \<^verbatim>\l\\ overload. The framed pullback constrains only the viewed +component and leaves the complement unconstrained, so it remains explicitly named. + +The precise pullback preserves \<^term>\emp\ and iterated separating conjunction. The framed +pullback is the precise pullback framed by \<^verbatim>\slens_kernel\; because it does not preserve +\<^term>\emp\, its iterated-conjunction law requires non-empty, upwards-closed factors. A non-empty +precise pullback is upwards closed only when the lens complement is trivial, so interface +assumptions that require upwards closure use the framed form.\ +definition pull_back_assertion :: \('s::zero, 't) lens \ 't assert \ 's assert\ + where \pull_back_assertion l \ = {lens_update l \ 0 | \. \ \ \}\ adhoc_overloading pull_back_const \ pull_back_assertion +definition pull_back_assertion_framed :: \('s, 't) lens \ 't assert \ 's assert\ + where \pull_back_assertion_framed l \ = {\. lens_view l \ \ \}\ + +lemma slens_view_zero: + fixes l :: \('s::sepalg, 't::sepalg) lens\ + assumes \is_valid_slens l\ + shows \lens_view l 0 = 0\ +proof - + have \0 \ (0 :: 's)\ + by fast + with assms have \lens_view l 0 \ lens_view l 0\ + by (simp add: is_valid_slens_def) + then show \lens_view l 0 = 0\ + using unique by fast +qed + +lemma slens_update_zero: + assumes \is_valid_slens l\ + shows \lens_update l 0 0 = 0\ + by (simp add: assms slens.slens_update_alt(2) unique) + lemma pull_back_assertion_compose: - shows \pull_back_assertion (l0 \\<^sub>L l1) \ = pull_back_assertion l0 (pull_back_assertion l1 \)\ - by (clarsimp simp add: pull_back_assertion_def asat_def compose_lens_components) + assumes \is_valid_slens l0\ + shows \pull_back_assertion (l0 \\<^sub>L l1) \ = + pull_back_assertion l0 (pull_back_assertion l1 \)\ + using assms + by (auto simp add: pull_back_assertion_def asat_def compose_lens_components slens_view_zero) + +lemma pull_back_assertion_framed_compose: + shows \pull_back_assertion_framed (l0 \\<^sub>L l1) \ = + pull_back_assertion_framed l0 (pull_back_assertion_framed l1 \)\ + by (clarsimp simp add: pull_back_assertion_framed_def asat_def compose_lens_components) definition pull_back_relation :: \('s, 't) lens \ ('t \ 'v \ 't \ bool) \ ('s \ 'v \ 's \ bool)\ where @@ -69,195 +108,509 @@ adhoc_overloading pull_back_const \ slens.pull_back_striple_c definition pull_back_contract where \pull_back_contract l \ \ make_function_contract_with_abort - (l\ (function_contract_pre \)) - (\r. l\ (function_contract_post \ r)) - (\r. l\ (function_contract_abort \ r)) + (pull_back_assertion l (function_contract_pre \)) + (\r. pull_back_assertion l (function_contract_post \ r)) + (\r. pull_back_assertion l (function_contract_abort \ r)) \ adhoc_overloading pull_back_const \ pull_back_contract +definition pull_back_contract_framed where + \pull_back_contract_framed l \ \ make_function_contract_with_abort + (pull_back_assertion_framed l (function_contract_pre \)) + (\r. pull_back_assertion_framed l (function_contract_post \ r)) + (\r. pull_back_assertion_framed l (function_contract_abort \ r)) + \ + +\\Precise and framed pullbacks use separate rule bundles because interface transfer also +consumes the framed rules backwards; combining them could rewrite a framed goal through a precise +pullback.\ named_theorems slens_pull_back_simps named_theorems slens_pull_back_intros +named_theorems slens_pull_back_precise_simps +named_theorems slens_pull_back_precise_intros + context slens begin -text\Pullback of assertions along separation lenses commutes with separation conjunction:\ +subsection\The precise pullback\ -lemma pull_back_assert_Union[slens_pull_back_simps]: +lemma pull_back_assert_Union[slens_pull_back_precise_simps]: shows \l\ (\x. \ x) = (\x. l\ (\ x))\ by (auto simp add: pull_back_assertion_def) -lemma pull_back_assertion_univ[slens_pull_back_simps]: - shows \l\ UNIV = UNIV\ - by (simp add: pull_back_assertion_def) - -lemma pull_back_assertion_false[slens_pull_back_simps]: +lemma pull_back_assertion_false[slens_pull_back_precise_simps]: shows \l\ {} = {}\ by (simp add: pull_back_assertion_def) -lemma pull_back_assertion_pure[slens_pull_back_simps]: - shows \l\ \P\ = \P\\ +lemma pull_back_assertion_emp[slens_pull_back_precise_simps]: + shows \l\ emp = emp\ + using slens_lens_laws(2)[of 0] slens_view_zero[OF slens_valid] + by (simp add: pull_back_assertion_def emp_def asat_def) + +text\Ordinary pure assertions permit arbitrary ownership, so their precise pullback also carries +the zero-complement restriction \<^term>\l\ UNIV\. Precise-pure assertions already own only zero +and are fixed.\ +lemma pull_back_assertion_pure[slens_pull_back_precise_simps]: + shows \l\ (apure P) = apure P \ l\ UNIV\ by (simp add: apure_def pull_back_assertion_def) -lemma pull_back_asepconj[slens_pull_back_simps]: +lemma pull_back_assertion_apure_precise[slens_pull_back_precise_simps]: + shows \l\ \P\ = \P\\ + by (simp add: apure_precise_def pull_back_assertion_def asat_def + slens_update_zero[OF slens_valid]) + +text\The precise pullback commutes with separating conjunction and its exact iteration.\ +lemma pull_back_asepconj[slens_pull_back_precise_simps]: fixes \ \ :: \'t assert\ shows \l\ (\ \ \) = (l\ \) \ (l\ \)\ apply (clarsimp simp add: asepconj_def pull_back_assertion_def asat_def aentails_def; safe) + apply (metis slens_embed_additive(1,2)) + apply (metis slens_embed_additive(2) slens_lens_laws(1) slens_view_local1) + done + +lemma pull_back_asepconj_multi'[slens_pull_back_precise_simps]: + shows \l\ (\ \\\ \) = {# l\ \ . \ \ \ #} \\\ l\ \\ + by (induction \) (simp_all add: asepconj_multi'_empty asepconj_multi'_add_mset + pull_back_asepconj) + +lemma pull_back_asepconj_multi[slens_pull_back_precise_simps]: + shows \l\ (\\ \) = \\ {# l\ \ . \ \ \ #}\ + by (simp add: asepconj_multi_def pull_back_asepconj_multi' pull_back_assertion_emp) + +text\The mapped form stays outside \<^verbatim>\slens_pull_back_precise_simps\: it introduces a +pullback while that bundle pushes pullbacks inward, so including both forms creates a rewrite +cycle.\ +lemma pull_back_asepconj_multi_map: + shows \\\{# l\ (\ a) . a \ ms #} = l\ (\\{# \ a . a \ ms #})\ + by (induction ms) (simp_all add: slens_pull_back_precise_simps asepconj_simp) + +corollary pull_back_asepconj_univ[slens_pull_back_precise_simps]: + fixes \ \ :: \'t assert\ + shows \l\ (\ \ UNIV) = (l\ \) \ l\ UNIV\ + by (simp add: slens_pull_back_precise_simps) + +text\The precise pullback is a full and faithful reading of the small algebra in the large one:\ +lemma pull_back_aentails[slens_pull_back_precise_simps]: + shows \(l\ \ \ l\ \) \ (\ \ \)\ +proof (rule, goal_cases) + case 1 + have embed_eq: \\y z. (slens_embed y = slens_embed z) \ (y = z)\ + using lens_valid by (metis slens_lens_laws(1)) + { + fix x + assume \x \ \\ + then have \lens_update l x 0 \ l\ \\ + by (force simp add: pull_back_assertion_def asat_def) + with 1 have \lens_update l x 0 \ l\ \\ + by (force simp add: aentails_def asat_def) + then have \x \ \\ + by (force simp add: pull_back_assertion_def asat_def embed_eq) + } + then show ?case + by (simp add: aentails_def asat_def) +next + case 2 + then show ?case + by (auto simp add: aentails_def asat_def pull_back_assertion_def) +qed + +lemma pull_back_asat_adjoint[slens_pull_back_precise_simps]: + shows \((lens_view l) \ \ \ \ slens_proj1 \ = 0) \ \ \ l\ \\ +proof + assume left: \(lens_view l) \ \ \ \ slens_proj1 \ = 0\ + have \\ = lens_update l (lens_view l \) 0 + slens_proj1 \\ + by (rule slens_decompose(1)) + also from left have \\ = lens_update l (lens_view l \) 0\ + by simp + finally have \\ = lens_update l (lens_view l \) 0\ . + with left show \\ \ l\ \\ + by (auto simp add: asat_def pull_back_assertion_def) +next + assume \\ \ l\ \\ + then obtain \ where \\ = lens_update l \ 0\ and \\ \ \\ + by (auto simp add: asat_def pull_back_assertion_def) + then show \(lens_view l) \ \ \ \ slens_proj1 \ = 0\ + by (simp add: slens_lens_laws slens_update_zero[OF slens_valid]) +qed + +lemma pull_back_assertion_int[slens_pull_back_precise_simps]: + shows \l\ (\ \ \) = l\ \ \ l\ \\ +proof - + have embed_eq: \\y z. (slens_embed y = slens_embed z) \ (y = z)\ + using lens_valid by (metis slens_lens_laws(1)) + show ?thesis + by (auto simp add: pull_back_assertion_def asat_def embed_eq) +qed + +lemma pull_back_contract_with_abort[slens_pull_back_precise_simps]: + \pull_back_contract l (make_function_contract_with_abort pre post ab) \ + make_function_contract_with_abort + (l\ pre) (\r. l\ (post r)) (\r. l\ (ab r))\ + by (clarsimp simp add: pull_back_contract_def) + +lemma pull_back_contract[slens_pull_back_precise_simps]: + \pull_back_contract l (make_function_contract pre post) \ + make_function_contract (l\ pre) (\r. l\ (post r))\ + by (clarsimp simp add: bot_fun_def slens_pull_back_precise_simps) + +lemma pull_back_aentailsI[slens_pull_back_precise_intros]: + assumes \\ \ \\ + shows \l\ \ \ l\ \\ + using assms pull_back_aentails by simp + +lemmas pull_back_aentailsE = pull_back_aentails[elim_format] + +text\A non-empty precise pullback is upwards closed only when every lens complement is zero.\ +lemma precise_ucincl_forces_trivial: + assumes \ucincl (l\ \)\ + and \l\ \ \ {}\ + shows \slens_proj1 \ = 0\ +proof - + from assms(2) obtain \ where t: \lens_update l \ 0 \ l\ \\ + by (auto simp add: pull_back_assertion_def asat_def) + have disj: \lens_update l \ 0 \ slens_proj1 \\ + by (metis disjoint_sym slens_complement_disj slens_lens_laws(1) zero_disjoint) + from assms(1) t disj have grown: \lens_update l \ 0 + slens_proj1 \ \ l\ \\ + using asat_weaken by blast + from disj have comm: \lens_update l \ 0 + slens_proj1 \ = slens_proj1 \ + lens_update l \ 0\ + by (simp add: sepalg_comm) + \\Upwards closure keeps the grown state in the precise pullback, whose complement is zero.\ + from grown comm have zero: \slens_proj1 (slens_proj1 \ + lens_update l \ 0) = 0\ + using pull_back_asat_adjoint by metis + have view0: \lens_view l (slens_proj1 \) = 0\ + by (simp add: slens_lens_laws(1)) + from zero view0 show \slens_proj1 \ = 0\ + by (simp add: slens_complement_cancel_core) +qed + +subsection\The framed pullback\ + +text\The framed pullback of assertions along separation lenses commutes with separation +conjunction:\ + +lemma pull_back_assertion_framed_Union[slens_pull_back_simps]: + shows \pull_back_assertion_framed l (\x. \ x) = + (\x. pull_back_assertion_framed l (\ x))\ + by (auto simp add: pull_back_assertion_framed_def) + +lemma pull_back_assertion_framed_univ[slens_pull_back_simps]: + shows \pull_back_assertion_framed l UNIV = UNIV\ + by (simp add: pull_back_assertion_framed_def) + +lemma pull_back_assertion_framed_false[slens_pull_back_simps]: + shows \pull_back_assertion_framed l {} = {}\ + by (simp add: pull_back_assertion_framed_def) + +lemma pull_back_assertion_framed_pure[slens_pull_back_simps]: + shows \pull_back_assertion_framed l (apure P) = apure P\ + by (simp add: apure_def pull_back_assertion_framed_def) + +text\A framed pullback enforces zero ownership only in the viewed component. Its complement is +therefore the lens kernel rather than \<^term>\emp\:\ +lemma pull_back_assertion_framed_apure_precise: + shows \pull_back_assertion_framed l \P\ = + apure P \ pull_back_assertion_framed l emp\ + by (auto simp add: pull_back_assertion_framed_def apure_precise_def apure_def emp_def asat_def) + +lemma pull_back_assertion_framed_asepconj[slens_pull_back_simps]: + fixes \ \ :: \'t assert\ + shows \pull_back_assertion_framed l (\ \ \) = + (pull_back_assertion_framed l \) \ (pull_back_assertion_framed l \)\ + apply (clarsimp simp add: asepconj_def pull_back_assertion_framed_def asat_def aentails_def; safe) apply (metis slens_lift_decomposition slens_valid) apply (meson slens_valid slens_view_local1 slens_view_local2) done -lemma pull_back_asepconj_multi[slens_pull_back_simps]: - shows \ l\ (\\{# \ x . x \ y #}) = \\{# l\ (\ x) . x \ y #}\ - by (induction y; clarsimp simp add: slens_pull_back_simps simp add: asepconj_simp) +text\The framed pullback commutes with iteration over an explicit starting value.\ +lemma pull_back_assertion_framed_asepconj_multi'[slens_pull_back_simps]: + shows \pull_back_assertion_framed l (\ \\\ \) = + {# pull_back_assertion_framed l \ . \ \ \ #} \\\ + pull_back_assertion_framed l \\ + by (induction \) (simp_all add: asepconj_multi'_empty asepconj_multi'_add_mset + pull_back_assertion_framed_asepconj) -corollary pull_back_asepconj_univ[slens_pull_back_simps]: +corollary pull_back_assertion_framed_asepconj_univ[slens_pull_back_simps]: fixes \ \ :: \'t assert\ - shows \l\ (\ \ UNIV) = (l\ \) \ UNIV\ + shows \pull_back_assertion_framed l (\ \ UNIV) = + (pull_back_assertion_framed l \) \ UNIV\ by (simp add: slens_pull_back_simps) -lemma pull_back_ucincl[slens_pull_back_intros]: +text\As a separating-conjunction factor, \<^term>\\P\\ passes through unchanged: +according to \<^term>\P\ it is the unit or annihilator, so the pullback acts only on the other +factor.\ +lemma pull_back_assertion_framed_apure_precise_asepconj: + shows \pull_back_assertion_framed l (\P\ \ \) = + \P\ \ pull_back_assertion_framed l \\ + by (cases P; simp add: asepconj_simp pull_back_assertion_framed_false) + +lemma pull_back_assertion_framed_asepconj_apure_precise: + shows \pull_back_assertion_framed l (\ \ \P\) = + pull_back_assertion_framed l \ \ \P\\ + by (cases P; simp add: asepconj_simp pull_back_assertion_framed_false) + +text\The middle-factor form fixes the rewrite order for transfer goals with a precise-pure +condition between two spatial factors.\ +lemma pull_back_assertion_framed_asepconj_apure_precise_asepconj: + shows \pull_back_assertion_framed l (\ \ \P\ \ \) = + pull_back_assertion_framed l \ \ \P\ \ pull_back_assertion_framed l \\ + by (subst pull_back_assertion_framed_asepconj, + subst pull_back_assertion_framed_apure_precise_asepconj, rule refl) + +text\These rules remain outside \<^verbatim>\slens_pull_back_simps\, which transfer proofs also use +in the reverse direction.\ + +lemma pull_back_assertion_framed_ucincl[slens_pull_back_intros]: assumes \ucincl \\ - shows \ucincl (l\ \)\ + shows \ucincl (pull_back_assertion_framed l \)\ proof - - have \l\ \ = l\ \ \ UNIV\ + have \pull_back_assertion_framed l \ = pull_back_assertion_framed l \ \ UNIV\ using assms by (clarsimp simp add: ucincl_alt simp flip: slens_pull_back_simps) from this show ?thesis using ucincl_alt by auto qed -lemma pull_back_aentails[slens_pull_back_simps]: - shows \(l\ \ \ l\ \) \ (\ \ \)\ +text\An upwards-closed assertion absorbs the framed pullback of \<^term>\emp\.\ +lemma pull_back_assertion_framed_emp_absorbed: + assumes \ucincl \\ + shows \\ \ pull_back_assertion_framed l emp = \\ +proof (intro aentails_eq) + show \\ \ pull_back_assertion_framed l emp \ \\ + using assms by (metis aentails_true asepconj_ident2 asepconj_mono) +next + have \emp \ pull_back_assertion_framed l emp\ + by (simp add: aentails_def asat_def emp_def pull_back_assertion_framed_def + slens_view_zero[OF slens_valid]) + then show \\ \ \ \ pull_back_assertion_framed l emp\ + by (rule asepconj_mono5) +qed + +text\The framed pullback commutes with a non-empty iteration of upwards-closed factors; both +side-conditions are determined by the rewrite target.\ +lemma pull_back_assertion_framed_asepconj_multi[slens_pull_back_simps]: + assumes \y \ {#}\ + and \\x. ucincl (\ x)\ + shows \pull_back_assertion_framed l (\\{# \ x . x \ y #}) = + \\{# pull_back_assertion_framed l (\ x) . x \ y #}\ +proof - + from assms have closed: \ucincl (\\{# pull_back_assertion_framed l (\ x) . x \ y #})\ + by (intro asepconj_multi_mapped_ucincl) (auto intro: pull_back_assertion_framed_ucincl) + have \pull_back_assertion_framed l (\\{# \ x . x \ y #}) = + {# pull_back_assertion_framed l (\ x) . x \ y #} \\\ + pull_back_assertion_framed l emp\ + by (simp only: asepconj_multi_def pull_back_assertion_framed_asepconj_multi' + multiset.map_comp comp_def) + also have \\ = \\{# pull_back_assertion_framed l (\ x) . x \ y #} \ + pull_back_assertion_framed l emp\ + by (simp only: asepconj_multi_multi') + finally show ?thesis + by (simp only: pull_back_assertion_framed_emp_absorbed[OF closed]) +qed + +lemma pull_back_assertion_framed_aentails[slens_pull_back_simps]: + shows \(pull_back_assertion_framed l \ \ pull_back_assertion_framed l \) \ + (\ \ \)\ proof - have \\x. lens_view l (lens_update l x 0) = x\ by (meson lens_laws lens_valid) from this have \\x. \y. lens_view l y = x\ by blast from this show ?thesis - by (auto simp add: asat_def aentails_def pull_back_assertion_def) metis + by (auto simp add: asat_def aentails_def pull_back_assertion_framed_def) metis qed -lemma pull_back_asat_adjoint[slens_pull_back_simps]: - shows \(lens_view l) \ \ \ \ \ \ l\ \\ - by (clarsimp simp add: pull_back_assertion_def asat_def) +lemma pull_back_assertion_framed_asat_adjoint[slens_pull_back_simps]: + shows \(lens_view l) \ \ \ \ \ \ pull_back_assertion_framed l \\ + by (clarsimp simp add: pull_back_assertion_framed_def asat_def) -lemma pull_back_assertion_int[slens_pull_back_simps]: - shows \l\ (\ \ \) = l\ \ \ l\ \\ - by (auto simp add: pull_back_assertion_def asat_def) +lemma pull_back_assertion_framed_int[slens_pull_back_simps]: + shows \pull_back_assertion_framed l (\ \ \) = + pull_back_assertion_framed l \ \ pull_back_assertion_framed l \\ + by (auto simp add: pull_back_assertion_framed_def asat_def) -lemma pull_back_contract_with_abort [slens_pull_back_simps]: - \pull_back_contract l (make_function_contract_with_abort pre post ab) \ +lemma pull_back_contract_framed_with_abort [slens_pull_back_simps]: + \pull_back_contract_framed l (make_function_contract_with_abort pre post ab) \ make_function_contract_with_abort - (l\ pre) (\r. l\ (post r)) (\r. l\ (ab r))\ - by (clarsimp simp add: pull_back_contract_def) + (pull_back_assertion_framed l pre) (\r. pull_back_assertion_framed l (post r)) + (\r. pull_back_assertion_framed l (ab r))\ + by (clarsimp simp add: pull_back_contract_framed_def) -lemma pull_back_contract [slens_pull_back_simps]: - \pull_back_contract l (make_function_contract pre post) \ +lemma pull_back_contract_framed [slens_pull_back_simps]: + \pull_back_contract_framed l (make_function_contract pre post) \ make_function_contract - (l\ pre) (\r. l\ (post r))\ + (pull_back_assertion_framed l pre) (\r. pull_back_assertion_framed l (post r))\ by (clarsimp simp add: bot_fun_def slens_pull_back_simps) -lemma pull_back_aentailsI[slens_pull_back_intros]: +lemma pull_back_assertion_framed_aentailsI[slens_pull_back_intros]: assumes \\ \ \\ - shows \l\ \ \ l\ \\ - using assms pull_back_aentails by simp + shows \pull_back_assertion_framed l \ \ pull_back_assertion_framed l \\ + using assms pull_back_assertion_framed_aentails by simp + +lemmas pull_back_assertion_framed_aentailsE = + pull_back_assertion_framed_aentails[elim_format] +subsection\The lens kernel\ + +text\The lens kernel contains states with an empty viewed component. Framing a precise pullback +with the kernel yields the framed pullback.\ + +definition slens_kernel :: \'s assert\ where + \slens_kernel \ pull_back_assertion_framed l emp\ + +lemma pull_back_assertion_precise_entails_framed: + shows \l\ \ \ pull_back_assertion_framed l \\ + by (auto simp add: aentails_def asat_def pull_back_assertion_def + pull_back_assertion_framed_def slens_lens_laws) + +lemma pull_back_assertion_framed_as_precise_raw: + shows \pull_back_assertion_framed l \ = l\ \ \ pull_back_assertion_framed l emp\ + apply (intro set_eqI iffI; clarsimp simp add: asepconj_def pull_back_assertion_def + pull_back_assertion_framed_def asat_def emp_def) + apply (metis slens_decompose(1) slens_decompose(2) slens_lens_laws(1)) + apply (clarsimp simp add: slens_view_local2 slens_lens_laws(1)) + done -lemmas pull_back_aentailsE = pull_back_aentails[elim_format] +text\Naming the kernel makes the framed/precise equation a terminating left-to-right rewrite.\ +lemma pull_back_assertion_framed_as_precise: + shows \pull_back_assertion_framed l \ = l\ \ \ slens_kernel\ + by (simp only: slens_kernel_def pull_back_assertion_framed_as_precise_raw[of \]) + +lemma slens_kernel_idem: + shows \slens_kernel \ slens_kernel = slens_kernel\ + by (simp add: slens_kernel_def asepconj_simp flip: pull_back_assertion_framed_asepconj) + +lemma slens_kernel_absorbed: + shows \slens_kernel \ pull_back_assertion_framed l \ = pull_back_assertion_framed l \\ + by (simp add: slens_kernel_def asepconj_simp flip: pull_back_assertion_framed_asepconj) + +text\A framed factor absorbs the kernel, allowing precise and framed factors in one separating +conjunction.\ +lemma pull_back_assertion_mixed_asepconj: + shows \l\ \ \ pull_back_assertion_framed l \ = pull_back_assertion_framed l (\ \ \)\ + apply (simp only: pull_back_assertion_framed_as_precise[of \] + pull_back_assertion_framed_as_precise[of \\ \ \\] pull_back_asepconj) + apply (metis asepconj_assoc) + done -text\The following is central: Assertion triples can be pulled back along separation lenses:\ +lemma pull_back_assertion_mixed_asepconj': + shows \pull_back_assertion_framed l \ \ l\ \ = pull_back_assertion_framed l (\ \ \)\ + by (metis asepconj_comm pull_back_assertion_mixed_asepconj) -lemma pull_back_atriple[slens_pull_back_intros]: +lemma pull_back_assertion_framed_absorbs_precise: + shows \l\ \ \ \ \ pull_back_assertion_framed l \ = + pull_back_assertion_framed l \ \ \ \ pull_back_assertion_framed l \\ + by (metis asepconj_AC(1) asepconj_AC(3) pull_back_assertion_framed_as_precise + slens_kernel_absorbed) + +subsection\Transport of triples and contracts\ + +text\Precise triple and contract transport is primitive. Framed transport follows by applying +the frame rules with \<^const>\slens_kernel\. Locality is antitone in its assertion, so precise +locality instead follows by weakening the framed law.\ + +lemma pull_back_atriple_precise[slens_pull_back_precise_intros]: assumes \\ \ (lens_view l s, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \\ - shows \l\ \ \ (s,lens_update l \' s) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k l\ \\ - using assms -proof - - assume \\ \ (lens_view l s, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \\ - let ?p = \lens_view l\ - { fix \ assume \ucincl \\ and \s \ l\ \ \ \\ - then obtain a b where \s = a + b\ and \a \ b\ and \a \ l\ \\ and \b \ \\ - using asepconjE by blast - from this have \?p s = ?p a + ?p b\ and \?p a \ ?p b\ - using slens_valid slens_view_local2 slens_view_local1 by blast+ - let ?pb = \?p b\ - let ?\' = \{?pb} \ \\ - have \ucincl ?\'\ - by (simp add: ucincl_UNIV ucincl_asepconjR) - moreover have \?pb \ ?\'\ - by (clarsimp simp add: asat_def asepconj_def) force - moreover from this and \?p s = ?p a + ?p b\ and \?p a \ ?p b\ \a \ l\ \\ - have \?p s \ \ \ ?\'\ - by (metis asat_def asepconjI mem_Collect_eq pull_back_assertion_def) - moreover from this and \ucincl ?\'\ and \\ \ (lens_view l s, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \\ have - \\' \ \ \ ?\'\ - using atriple_def by blast - moreover from this obtain a' b' where \\' = a' + b'\ and \a' \ b'\ and \a' \ \\ - and \b' \ ?\'\ - using asepconjE by blast - moreover from this obtain b0 where \b' = ?pb + b0\ and \?pb \ b0\ - by (metis asat_def asepconjE singletonD) - moreover from calculation have \lens_update l \' s = lens_update l a' a + lens_update l b' b\ - using slens_valid slens_update_general by (metis \a \ b\ \s = a + b\) - moreover from calculation have \lens_update l a' a \ lens_update l b' b\ - by (metis \a \ b\ disjoint_sym sepalg_apart_plus2 slens_lens_laws(1) slens_update_local4) - moreover from calculation have \lens_update l a' a \ l\ \\ - by (metis lens_laws_update(1) local.lens_valid pull_back_asat_adjoint) - moreover from calculation have \lens_update l b' b = b + lens_update l b0 0\ - by (metis slens_lens_laws(2) slens_update_disjoint) - moreover from this have \lens_update l b' b \ \\ - by (metis \b \ \\ \ucincl \\ asat_weaken calculation(10) slens_complement_disj) - ultimately have \lens_update l \' s \ l\ \ \ \\ - by (metis asat_def asepconjI) } - from this show \l\ \ \ (s,lens_update l \' s) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k l\ \\ - by (meson asat_def atripleI) + shows \l\ \ \ (s, lens_update l \' s) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k l\ \\ +proof (rule atripleI) + fix \ + assume input: \s \ l\ \ \ \\ + from input obtain a b where split: + \s = a + b\ \a \ b\ \a \ l\ \\ \b \ \\ + using asepconjE by blast + \\The precise left summand has zero complement, so the full lens complement lies in the + frame.\ + from split(3) obtain t where t: \a = lens_update l t 0\ \t \ \\ + by (auto simp add: asat_def pull_back_assertion_def) + from t have view_a: \lens_view l a = t\ + by (simp add: slens_lens_laws(1)) + from split(1,2) view_a have view_split: \lens_view l s = t + lens_view l b\ + by (simp add: slens_view_local2) + from split(2) view_a have view_apart: \t \ lens_view l b\ + by (metis slens_view_local1) + \\The singleton viewed frame preserves that component exactly.\ + from view_split view_apart t(2) have view_input: \lens_view l s \ \ \ {lens_view l b}\ + by (simp add: asepconj_def asat_def) blast + from assms view_input have output_sat: \\' \ \ \ {lens_view l b}\ + using atriple_def by blast + from output_sat obtain a' where out: + \\' = a' + lens_view l b\ \a' \ lens_view l b\ \a' \ \\ + by (auto simp add: asepconj_def asat_def) + from split(1,2) out(1,2) view_apart t view_a have update_split: + \lens_update l \' s = lens_update l a' a + lens_update l (lens_view l b) b\ + using slens_update_general by (metis slens_view_local1) + from t(1) have left_eq: \lens_update l a' a = lens_update l a' 0\ + by (simp add: slens_lens_laws) + have right_eq: \lens_update l (lens_view l b) b = b\ + by (simp add: slens_lens_laws) + from out(3) have left_sat: \lens_update l a' 0 \ l\ \\ + by (auto simp add: asat_def pull_back_assertion_def) + from out(2) split(2) t(1) have update_apart: \lens_update l a' 0 \ b\ + by (metis slens_complement_disj disjoint_sym slens_lens_laws(1) slens_view_local1) + show \lens_update l \' s \ l\ \ \ \\ + using update_split left_eq right_eq left_sat update_apart split(4) by (metis asepconjI) qed -lemma pull_back_striple[slens_pull_back_intros]: +lemma pull_back_atriple[slens_pull_back_intros]: + assumes \\ \ (lens_view l s, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \\ + shows \pull_back_assertion_framed l \ \ (s,lens_update l \' s) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k pull_back_assertion_framed l \\ + by (simp only: pull_back_assertion_framed_as_precise, + rule atriple_frame_rule[OF pull_back_atriple_precise[OF assms]]) + +lemma pull_back_striple_precise[slens_pull_back_precise_intros]: fixes e :: \('t, 'v, 'r, 'abort, 'i prompt, 'o prompt_output) expression\ assumes T: \\; \ \ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \\ - and \is_canonical_lifted_striple_context l \ \\ - shows \\; l\ \ \ l\ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\v. l\ (\ v)) \ (\r. l\ (\ r)) \ (\r. l\ (\ r))\ + and C: \is_canonical_lifted_striple_context l \ \\ + shows \\; l\ \ \ l\ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k + (\v. l\ (\ v)) \ (\r. l\ (\ r)) \ (\r. l\ (\ r))\ proof - - from \is_canonical_lifted_striple_context l \ \\ have - YH: \yh \ = canonical_pull_back_yield_handler l (yh \)\ + from C have YH: \yh \ = canonical_pull_back_yield_handler l (yh \)\ unfolding is_canonical_lifted_striple_context_def by simp - note assms = YH T show ?thesis -proof (intro stripleI) - fix v s s' - assume \s \\<^sub>v \yield_handler \,l\ e\ (v,s')\ - from this obtain \' where - \s' = lens_update l \' s\ and \lens_view l s \\<^sub>v \yh \, e\ (v, \')\ - using YH expression_pull_back_eval_value_canonical[OF lens_valid] by metis - from this and \\; \ \ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \\ obtain \\ \ (lens_view l s,\') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ v\ - by (meson stripleE_value) - from this and \s' = lens_update l \' s\ and pull_back_atriple - show \l\ \ \ (s,s') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k l\ (\ v)\ - by simp -next - fix r s s' - assume \s \\<^sub>r \yield_handler \,l\ e\ (r,s')\ - from this obtain \' where - \s' = lens_update l \' s\ and \lens_view l s \\<^sub>r \yh \, e\ (r, \')\ - using YH expression_pull_back_eval_return_canonical[OF lens_valid] by metis - from this and \\; \ \ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \\ obtain \\ \ (lens_view l s,\') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ r\ - by (meson stripleE_return) - from this and \s' = lens_update l \' s\ and pull_back_atriple - show \l\ \ \ (s,s') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k l\ (\ r)\ - by simp -next - fix a s s' - assume \s \\<^sub>a \yield_handler \,l\ e\ (a,s')\ - from this obtain \' where - \s' = lens_update l \' s\ and \lens_view l s \\<^sub>a \yh \, e\ (a, \')\ - using YH expression_pull_back_eval_abort_canonical[OF lens_valid] by metis - from this and \\; \ \ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \\ obtain \\ \ (lens_view l s,\') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ a\ - by (meson stripleE_abort) - from this and \s' = lens_update l \' s\ and pull_back_atriple - show \l\ \ \ (s,s') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k l\ (\ a)\ + proof (intro stripleI) + fix v s s' + assume \s \\<^sub>v \yield_handler \,l\ e\ (v,s')\ + from this obtain \' where + \s' = lens_update l \' s\ and \lens_view l s \\<^sub>v \yh \, e\ (v, \')\ + using YH expression_pull_back_eval_value_canonical[OF lens_valid] by metis + from this and T obtain \\ \ (lens_view l s,\') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ v\ + by (meson stripleE_value) + from this and \s' = lens_update l \' s\ and pull_back_atriple_precise + show \l\ \ \ (s,s') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k l\ (\ v)\ + by simp + next + fix r s s' + assume \s \\<^sub>r \yield_handler \,l\ e\ (r,s')\ + from this obtain \' where + \s' = lens_update l \' s\ and \lens_view l s \\<^sub>r \yh \, e\ (r, \')\ + using YH expression_pull_back_eval_return_canonical[OF lens_valid] by metis + from this and T obtain \\ \ (lens_view l s,\') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ r\ + by (meson stripleE_return) + from this and \s' = lens_update l \' s\ and pull_back_atriple_precise + show \l\ \ \ (s,s') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k l\ (\ r)\ + by simp + next + fix a s s' + assume \s \\<^sub>a \yield_handler \,l\ e\ (a,s')\ + from this obtain \' where + \s' = lens_update l \' s\ and \lens_view l s \\<^sub>a \yh \, e\ (a, \')\ + using YH expression_pull_back_eval_abort_canonical[OF lens_valid] by metis + from this and T obtain \\ \ (lens_view l s,\') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ a\ + by (meson stripleE_abort) + from this and \s' = lens_update l \' s\ and pull_back_atriple_precise + show \l\ \ \ (s,s') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k l\ (\ a)\ by simp qed qed +lemma pull_back_striple[slens_pull_back_intros]: + fixes e :: \('t, 'v, 'r, 'abort, 'i prompt, 'o prompt_output) expression\ + assumes T: \\; \ \ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \\ + and C: \is_canonical_lifted_striple_context l \ \\ + shows \\; pull_back_assertion_framed l \ \ l\ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k + (\v. pull_back_assertion_framed l (\ v)) \ (\r. pull_back_assertion_framed l (\ r)) + \ (\r. pull_back_assertion_framed l (\ r))\ + by (simp only: pull_back_assertion_framed_as_precise, + rule striple_frame_rule[OF pull_back_striple_precise[OF T C]]) + notation slens_embed ("\") notation slens_view ("\") notation slens_proj0 ("\\<^sub>0") @@ -266,18 +619,18 @@ notation slens_proj1 ("\\<^sub>1") lemma pull_back_local_relation_disj: assumes \is_local R \\ shows \\\_0 \_1 \_0' v. - \_0 \ \_1 \ \_0 \ l\ \ \ l\ R \_0 (v, \_0') \ \_0' \ \_1\ + \_0 \ \_1 \ \_0 \ pull_back_assertion_framed l \ \ l\ R \_0 (v, \_0') \ \_0' \ \_1\ proof - fix \_0 \_1 \_0' v - assume \\_0 \ \_1\ and \\_0 \ l\ \\ and \l\ R \_0 (v, \_0')\ + assume \\_0 \ \_1\ and \\_0 \ pull_back_assertion_framed l \\ and \l\ R \_0 (v, \_0')\ moreover from \l\ R \_0 (v, \_0')\ obtain \' where \R (\ \_0) (v, \')\ and \\_0' = \\<^sub>1 \_0 + \ \'\ apply (clarsimp simp add: pull_back_relation_def) using slens_update_alt(1) slens_valid by blast - moreover from \\_0 \ \_1\ and \\_0 \ l\ \\ have + moreover from \\_0 \ \_1\ and \\_0 \ pull_back_assertion_framed l \\ have \\ \_0 \ \ \_1\ and \\ \_0 \ \\ apply (simp add: slens_view_local1) - apply (metis \\_0 \ l\ \\ asat_def mem_Collect_eq pull_back_assertion_def) + apply (metis \\_0 \ pull_back_assertion_framed l \\ asat_def mem_Collect_eq pull_back_assertion_framed_def) done moreover from this and \is_local R \\ have \\' \ \ \_1\ by (meson calculation(4) is_localE) @@ -287,15 +640,15 @@ qed lemma pull_back_local_relation[slens_pull_back_intros]: assumes \is_local R \\ - shows \is_local (l\ R) (l\ \)\ + shows \is_local (l\ R) (pull_back_assertion_framed l \)\ proof (intro is_localI) fix \_0 \_1 \_0' v - assume \\_0 \ \_1\ and \\_0 \ l\ \\ and \l\ R \_0 (v, \_0')\ + assume \\_0 \ \_1\ and \\_0 \ pull_back_assertion_framed l \\ and \l\ R \_0 (v, \_0')\ from this show \\_0' \ \_1\ by (metis assms pull_back_local_relation_disj) next fix \_0 \_1 \' v - assume \\_0 \ \_1\ and \\_0 \ l\ \\ and \l\ R (\_0 + \_1) (v, \')\ + assume \\_0 \ \_1\ and \\_0 \ pull_back_assertion_framed l \\ and \l\ R (\_0 + \_1) (v, \')\ moreover from this obtain \' where \R (\ (\_0 + \_1)) (v, \')\ and \lens_update l \' (\_0 + \_1) = \'\ unfolding pull_back_relation_def by auto @@ -306,9 +659,9 @@ next moreover from calculation obtain \_0'' where \R (\ \_0) (v, \_0'')\ and \\' = \_0'' + \ \_1\ using slens_valid \is_local R \\ unfolding is_local_def - by (meson is_valid_slensE pull_back_asat_adjoint) + by (meson is_valid_slensE pull_back_assertion_framed_asat_adjoint) moreover from calculation have \\_0'' \ \ \_1\ - using slens_valid by (meson assms is_localE pull_back_asat_adjoint slens_view_local1) + using slens_valid by (meson assms is_localE pull_back_assertion_framed_asat_adjoint slens_view_local1) moreover note facts = calculation let ?\_0' = \\\<^sub>1 \_0 + \ \_0''\ from facts have \\\<^sub>1 \' = \\<^sub>1 ?\_0' + \\<^sub>1 \_1\ @@ -326,7 +679,7 @@ next next fix \_0 \_1 \_0' v \' assume \\_0 \ \_1\ - and \\_0 \ l\ \\ + and \\_0 \ pull_back_assertion_framed l \\ and \l\ R \_0 (v, \_0') \ \' = \_0' + \_1\ moreover from this have \\_0' \ \_1\ by (meson assms pull_back_local_relation_disj) @@ -337,7 +690,7 @@ next moreover from calculation have \\ \' = \ \_0' + \ \_1\ using slens_valid slens_view_local2 by blast moreover from calculation and \is_local R \\ have \R (\ \_0 + \ \_1) (v, \' + \ \_1)\ - using slens_valid by (metis asat_def is_localE mem_Collect_eq pull_back_assertion_def slens_view_local1) + using slens_valid by (metis asat_def is_localE mem_Collect_eq pull_back_assertion_framed_def slens_view_local1) moreover from calculation have \\' = lens_update l (\' + \ \_1) (\_0 + \_1)\ using slens_valid by (metis slens_lens_laws(1) slens_update_local3 slens_view_local1) moreover have \\ (\_0 + \_1) = \ \_0 + \ \_1\ @@ -349,7 +702,7 @@ qed lemma pull_back_local_urust: assumes \urust_is_local y e \\ - shows \urust_is_local (l\ y) (l\ e) (l\ \)\ + shows \urust_is_local (l\ y) (l\ e) (pull_back_assertion_framed l \)\ using assms by (clarsimp simp add: pull_back_relation_def expression_pull_back_eval_value_canonical[OF lens_valid] @@ -357,16 +710,31 @@ lemma pull_back_local_urust: expression_pull_back_eval_return_canonical[OF lens_valid] elim!: pull_back_local_relation[elim_format]) -lemma pull_back_sstriple[slens_pull_back_intros]: +lemma pull_back_local_urust_precise: + assumes \urust_is_local y e \\ + shows \urust_is_local (l\ y) (l\ e) (l\ \)\ + by (rule urust_is_local_weaken[OF pull_back_assertion_precise_entails_framed + pull_back_local_urust[OF assms]]) + +lemma pull_back_sstriple_precise[slens_pull_back_precise_intros]: fixes e :: \('t, 'v, 'r, 'abort, 'i prompt, 'o prompt_output) expression\ assumes T: \\; \ \ e \ \ \ \ \ \\ - shows \l\ \; l\ \ \ l\ e \ (\v. l\ (\ v)) \ (\r. l\ (\ r)) \ (\r. l\ (\ r))\ + shows \l\ \; l\ \ \ l\ e \ + (\v. l\ (\ v)) \ (\r. l\ (\ r)) \ (\r. l\ (\ r))\ using assms by (clarsimp simp add: sstriple_striple' is_canonical_lifted_striple_context_def - pull_back_local_urust pull_back_striple pull_back_striple_context_yield_handler) + pull_back_local_urust_precise pull_back_striple_precise + pull_back_striple_context_yield_handler) -\\This is an artifact of the current use of \<^verbatim>\\\ as the abort-postcondition in function contracts. - Once we generalize, this should no longer be necessary.\ -lemma pull_back_sstriple_bot[slens_pull_back_intros]: +lemma pull_back_sstriple[slens_pull_back_intros]: + fixes e :: \('t, 'v, 'r, 'abort, 'i prompt, 'o prompt_output) expression\ + assumes T: \\; \ \ e \ \ \ \ \ \\ + shows \l\ \; pull_back_assertion_framed l \ \ l\ e \ + (\v. pull_back_assertion_framed l (\ v)) \ (\r. pull_back_assertion_framed l (\ r)) + \ (\r. pull_back_assertion_framed l (\ r))\ + by (simp only: pull_back_assertion_framed_as_precise, + rule sstriple_frame_rule[OF pull_back_sstriple_precise[OF T]]) + +lemma pull_back_sstriple_bot_precise[slens_pull_back_precise_intros]: fixes e :: \('t, 'v, 'r, 'abort, 'i prompt, 'o prompt_output) expression\ assumes T: \\; \ \ e \ \ \ \ \ \\ shows \l\ \; l\ \ \ l\ e \ (\v. l\ (\ v)) \ (\r. l\ (\ r)) \ \\ @@ -374,37 +742,87 @@ proof - let ?bot = \(\_. \) :: 'abort abort \ 't assert\ have eq: \\ = (\r. (l\ (?bot r)))\ by (simp add: bot_fun_def pull_back_assertion_false) + from this assms pull_back_sstriple_precise show ?thesis + by fastforce +qed + +\\This is an artifact of the current use of \<^verbatim>\\\ as the abort-postcondition in function contracts. + Once we generalize, this should no longer be necessary.\ +lemma pull_back_sstriple_bot[slens_pull_back_intros]: + fixes e :: \('t, 'v, 'r, 'abort, 'i prompt, 'o prompt_output) expression\ + assumes T: \\; \ \ e \ \ \ \ \ \\ + shows \l\ \; pull_back_assertion_framed l \ \ l\ e \ + (\v. pull_back_assertion_framed l (\ v)) \ (\r. pull_back_assertion_framed l (\ r)) \ \\ +proof - + let ?bot = \(\_. \) :: 'abort abort \ 't assert\ + have eq: \\ = (\r. (pull_back_assertion_framed l (?bot r)))\ + by (simp add: bot_fun_def pull_back_assertion_framed_false) from this assms pull_back_sstriple show ?thesis by fastforce qed -lemma pull_back_sstriple_universal_bot[slens_pull_back_intros]: +lemma pull_back_sstriple_universal_bot_precise[slens_pull_back_precise_intros]: assumes \\\. \; \ \ e \ \ \ \ \ \\ shows \\\. \; l\ \ \ l\ e \ (\v. l\ (\ v)) \ (\r. l\ (\ r)) \ \\ proof - from assms have \striple_context_no_yield; \ \ e \ \ \ \ \ \\ by simp - from this have \l\ striple_context_no_yield; l\ \ \ l\ e \ (\v. l\ (\ v)) \ (\r. l\ (\ r)) \ \\ + from this have \l\ striple_context_no_yield; l\ \ \ l\ e \ + (\v. l\ (\ v)) \ (\r. l\ (\ r)) \ \\ + by (intro pull_back_sstriple_bot_precise; assumption) + from this have \striple_context_no_yield; l\ \ \ l\ e \ + (\v. l\ (\ v)) \ (\r. l\ (\ r)) \ \\ + using lens_valid by force + from this show \\\. \ ; l\ \ \ l\ e \ + (\v. l\ (\ v)) \ (\r. l\ (\ r)) \ \\ + using sstriple_yield_handler_no_yield_implies_all by blast +qed + +lemma pull_back_sstriple_universal_bot[slens_pull_back_intros]: + assumes \\\. \; \ \ e \ \ \ \ \ \\ + shows \\\. \; pull_back_assertion_framed l \ \ l\ e \ + (\v. pull_back_assertion_framed l (\ v)) \ (\r. pull_back_assertion_framed l (\ r)) \ \\ +proof - + from assms have \striple_context_no_yield; \ \ e \ \ \ \ \ \\ + by simp + from this have \l\ striple_context_no_yield; pull_back_assertion_framed l \ \ l\ e \ + (\v. pull_back_assertion_framed l (\ v)) \ (\r. pull_back_assertion_framed l (\ r)) \ \\ by (intro pull_back_sstriple_bot; assumption) - from this have \striple_context_no_yield; l\ \ \ l\ e \ (\v. l\ (\ v)) \ (\r. l\ (\ r)) \ \\ + from this have \striple_context_no_yield; pull_back_assertion_framed l \ \ l\ e \ + (\v. pull_back_assertion_framed l (\ v)) \ (\r. pull_back_assertion_framed l (\ r)) \ \\ using lens_valid by force - from this show \\\. \ ; l\ \ \ l\ e \ (\v. l\ (\ v)) \ (\r. l\ (\ r)) \ \\ + from this show \\\. \ ; pull_back_assertion_framed l \ \ l\ e \ + (\v. pull_back_assertion_framed l (\ v)) \ (\r. pull_back_assertion_framed l (\ r)) \ \\ using sstriple_yield_handler_no_yield_implies_all by blast qed +lemma pull_back_spec_precise[slens_pull_back_precise_intros]: + assumes \\ ; f \\<^sub>F \\ + shows \l\ \; l\ f \\<^sub>F pull_back_contract l \\ + using assms unfolding satisfies_function_contract_def pull_back_contract_def + by (clarsimp simp add: function_pull_back_def pull_back_sstriple_precise) + lemma pull_back_spec[slens_pull_back_intros]: assumes \\ ; f \\<^sub>F \\ - shows \l\ \; l\ f \\<^sub>F l\ \\ + shows \l\ \; l\ f \\<^sub>F pull_back_contract_framed l \\ + using assms unfolding satisfies_function_contract_def pull_back_contract_framed_def + by (clarsimp simp add: function_pull_back_def pull_back_sstriple) + +lemma pull_back_spec_universal_precise: + assumes \\\. \; f \\<^sub>F \\ + and \function_contract_abort \ = \\ + shows \\\. \; l\ f \\<^sub>F pull_back_contract l \\ using assms unfolding satisfies_function_contract_def pull_back_contract_def - by (clarsimp simp add: pull_back_ucincl function_pull_back_def pull_back_sstriple) + by (simp add: function_pull_back_def pull_back_sstriple_universal_bot_precise + slens_pull_back_precise_simps bot_fun_def[symmetric]) lemma pull_back_spec_universal: assumes \\\. \; f \\<^sub>F \\ and \function_contract_abort \ = \\ - shows \\\. \; l\ f \\<^sub>F l\ \\ - using assms unfolding satisfies_function_contract_def pull_back_contract_def - by (simp add: function_pull_back_def pull_back_sstriple_universal_bot pull_back_ucincl - slens_pull_back_simps bot_fun_def[symmetric] ucincl_intros) + shows \\\. \; l\ f \\<^sub>F pull_back_contract_framed l \\ + using assms unfolding satisfies_function_contract_def pull_back_contract_framed_def + by (simp add: function_pull_back_def pull_back_sstriple_universal_bot + slens_pull_back_simps bot_fun_def[symmetric]) no_notation slens_embed ("\") no_notation slens_view ("\") diff --git a/Shallow_Separation_Logic/Adequacy.thy b/Shallow_Separation_Logic/Adequacy.thy index 913a84db..9d5039c4 100644 --- a/Shallow_Separation_Logic/Adequacy.thy +++ b/Shallow_Separation_Logic/Adequacy.thy @@ -27,27 +27,26 @@ Function contracts \<^term>\satisfies_function_contract\ \end{itemize*}\ subsection\Low-level adequacy results\ -text\Note that the final \<^verbatim>\shows\ clauses of all these theorems is of shape \<^term>\\ \ \\: the -upward closedness requirements (\<^term>\ucincl\) is part of the definition of these triples.\ +text\Exact triples make each post-condition hold of the output state itself:\ lemma atriple_rel_eval_value_adequacy: assumes \\ \ eval_value Y e \\<^sub>R \\ and \\ \ \\ and \continuation.Success v \' \ deep_evaluates_nondet_basic Y e \\ - shows \\' \ \ v \ \\ + shows \\' \ \ v\ using assms by (auto simp add: atriple_rel_def eval_value_def urust_eval_predicate_defs) lemma atriple_rel_eval_return_adequacy: assumes \\ \ eval_return Y e \\<^sub>R \\ and \\ \ \\ and \continuation.Return v \' \ deep_evaluates_nondet_basic Y e \\ - shows \\' \ \ v \ \\ + shows \\' \ \ v\ using assms by (auto simp add: atriple_rel_def eval_return_def urust_eval_predicate_defs) lemma atriple_rel_eval_abort_adequacy: assumes \\ \ eval_abort Y e \\<^sub>R \\ and \\ \ \\ and \continuation.Abort a \' \ deep_evaluates_nondet_basic Y e \\ - shows \\' \ \ a \ \\ + shows \\' \ \ a\ using assms by (auto simp add: atriple_rel_def eval_abort_def urust_eval_predicate_defs) subsection\Main adequacy results\ @@ -56,9 +55,9 @@ lemma sstriple_adequacy: and \\ \ \\ and \c \ deep_evaluates_nondet_basic (yield_handler \) e \\ shows \case c of - continuation.Success v \' \ \' \ \ v \ \ - | continuation.Return v \' \ \' \ \ v \ \ - | continuation.Abort a \' \ \' \ \ a \ \ + continuation.Success v \' \ \' \ \ v + | continuation.Return v \' \ \' \ \ v + | continuation.Abort a \' \ \' \ \ a | continuation.Yield _ _ _ \ False\ \ \Evaluating with \<^term>\deep_evaluates_nondet_basic\ will never terminate in \<^term>\Yield\\ using assms @@ -71,15 +70,14 @@ corollary wp_adequacy: and \\ \ \\ and \c \ deep_evaluates_nondet_basic (yield_handler \) e \\ shows \case c of - continuation.Success v \' \ \' \ \ v \ \ - | continuation.Return v \' \ \' \ \ v \ \ - | continuation.Abort a \' \ \' \ \ a \ \ + continuation.Success v \' \ \' \ \ v + | continuation.Return v \' \ \' \ \ v + | continuation.Abort a \' \ \' \ \ a | continuation.Yield _ _ _ \ False\ using assms by (auto simp add: sstriple_adequacy dest!: wp_to_sstriple) -text\Function contracts (\<^term>\satisfies_function_contract\) additionaly require \<^term>\ucincl\ on -the pre-, post- and abort conditions. This means we can get rid of program logic connectives -altogether, replacing \<^term>\\ \ \ \ \\ with \<^term>\\ \ \\\ +text\Contract adequacy is stated directly in terms of assertion membership; contract +conditions need not be upwards closed.\ corollary contract_adequacy: assumes \\; body \\<^sub>F contract\ and \\ \ function_contract_pre contract\ @@ -90,7 +88,7 @@ corollary contract_adequacy: | continuation.Abort a \' \ \' \ function_contract_abort contract a | continuation.Yield _ _ _ \ False\ using assms - by (auto simp add: asat_def asepconj_ident2 satisfies_function_contract_def + by (auto simp add: asat_def satisfies_function_contract_def split: continuation.splits dest!: sstriple_adequacy) definition is_yield :: \('a, 'b, 'c, 'd, 'e, 'f) continuation \ bool\ where @@ -103,9 +101,9 @@ corollary wp_adequacy_deterministic: and \\ \ \\ and \\ is_yield (evaluate e \)\ shows \case evaluate e \ of - continuation.Success v \' \ \' \ \ v \ \ - | continuation.Return v \' \ \' \ \ v \ \ - | continuation.Abort a \' \ \' \ \ a \ \ + continuation.Success v \' \ \' \ \ v + | continuation.Return v \' \ \' \ \ v + | continuation.Abort a \' \ \' \ \ a | continuation.Yield _ _ _ \ False\ using assms(3) wp_adequacy[OF assms(1) assms(2), where c=\evaluate e \\] by (auto simp add: deep_evaluate_basic_SuccessI deep_evaluate_basic_ReturnI @@ -131,9 +129,9 @@ text\These results could in principle be extended to use \<^term>\de of \<^term>\evaluate\.\ lemma sstriple_from_evaluation: assumes \\ \. \ \ \ \ case evaluate e \ of - continuation.Success v \' \ \' \ \ v \ \ - | continuation.Return v \' \ \' \ \ v \ \ - | continuation.Abort a \' \ \' \ \ a \ \ + continuation.Success v \' \ \' \ \ v + | continuation.Return v \' \ \' \ \ v + | continuation.Abort a \' \ \' \ \ a | continuation.Yield _ _ _ \ False\ and \urust_is_local (yh \) e \\ shows \\ ; \ \ e \ \ \ \ \ \\ @@ -144,9 +142,9 @@ lemma sstriple_from_evaluation: lemma wp_from_evaluation: assumes \\ \. \ \ \ \ case evaluate e \ of - continuation.Success v \' \ \' \ \ v \ \ - | continuation.Return v \' \ \' \ \ v \ \ - | continuation.Abort a \' \ \' \ \ a \ \ + continuation.Success v \' \ \' \ \ v + | continuation.Return v \' \ \' \ \ v + | continuation.Abort a \' \ \' \ \ a | continuation.Yield _ _ _ \ False\ and \urust_is_local (yh \) e \\ shows \\ \ \\

\ e \ \ \\ @@ -159,13 +157,10 @@ lemma contract_from_evaluation: | continuation.Abort a \' \ \' \ function_contract_abort contract a | continuation.Yield _ _ _ \ False\ and \urust_is_local (yh \) (function_body func) (function_contract_pre contract)\ - and \ucincl (function_contract_pre contract)\ - and \\ v. ucincl (function_contract_post contract v)\ - and \\ v. ucincl (function_contract_abort contract v)\ shows \\; func \\<^sub>F contract\ - using assms(2-) - by (auto intro!: sstriple_from_evaluation simp add: satisfies_function_contract_def asepconj_ident2 - dest!: assms(1) split: continuation.splits) + using assms + by (auto intro!: sstriple_from_evaluation simp add: satisfies_function_contract_def + split: continuation.splits) subsection\Evaluating pure functions\ text\To start off, some technical results showing that \<^term>\urust_is_local\ holds if evaluating @@ -186,16 +181,16 @@ text\Now, we can derive quite simple lemmas to derive \<^term>\\\ contracts for such expressions\ corollary pure_function_derive_wp: assumes \\ m. evaluate e m = continuation.Success v m\ - shows \\ \ \\

\ e (\ r. \r = v\) \ \\ + shows \\ \ \\

\ e (\ r. apure (r = v)) \ \\ using assms by (auto intro!: wp_from_evaluation success_independent_of_machine_then_local simp add: asepconj_False_True asepconj_UNIV_idempotent) corollary pure_function_derive_contract: assumes \\ m. evaluate (function_body func) m = continuation.Success v m\ - shows \\; func \\<^sub>F make_function_contract \ (\ r. \r = v\)\ + shows \\; func \\<^sub>F make_function_contract \ (\ r. apure (r = v))\ using assms - by (auto intro!: contract_from_evaluation success_independent_of_machine_then_local ucincl_apure) + by (auto intro!: contract_from_evaluation success_independent_of_machine_then_local) text\With these results, one can first prove that there exists some \<^term>\v\ such that your expression evaluates to that value \<^term>\v\, and then define the 'pure' counterpart of your expression diff --git a/Shallow_Separation_Logic/Assertion_Language.thy b/Shallow_Separation_Logic/Assertion_Language.thy index e41ccb6a..01deaa27 100644 --- a/Shallow_Separation_Logic/Assertion_Language.thy +++ b/Shallow_Separation_Logic/Assertion_Language.thy @@ -471,6 +471,25 @@ lemma asepconj_ident2 [asepconj_simp]: shows \\ \ \ = \\ using assms ucincl_alt by simp +text \The empty assertion owns exactly the empty machine state and is the +unconditional unit of separating conjunction.\ +definition emp :: \'a assert\ where + \emp \ {0}\ + +lemma asat_emp [asat_simp, simp]: + shows \x \ emp \ x = 0\ +by (simp add: asat_def emp_def) + +lemma asepconj_emp_unit [asepconj_simp]: + shows \\ \ emp = \\ and \emp \ \ = \\ +proof - + show \\ \ emp = \\ + by (intro asat_semequivI) (auto simp add: asat_emp elim!: asepconjE + intro!: asepconjI [where ?z=0]) + from this show \emp \ \ = \\ + by (simp add: asepconj_comm) +qed + text \The Boolean truth value is \<^emph>\idempotent\ with respect to the separating conjunction:\ lemma asepconj_UNIV_idempotent [asepconj_simp]: shows \\ \ \ = \\ @@ -507,11 +526,22 @@ lemma ucincl_asepconjL [ucincl_intros]: shows \ucincl (\ \ \)\ using assms by (simp only: ucincl_alt) (metis asepconj_assoc asepconj_comm) -lemma ucincl_asepconjR: +\\Both orientations participate in closure search. Each leaves a strictly smaller +\<^const>\ucincl\ goal, and the left-oriented rule is tried first.\ +lemma ucincl_asepconjR [ucincl_intros]: assumes \ucincl \\ shows \ucincl (\ \ \)\ using assms asepconj_comm ucincl_asepconjL by force +notepad +begin + \\The theorem bundle closes a right-oriented conjunction.\ + fix \ \ :: \'a assert\ + assume \ucincl \\ + then have \ucincl (\ \ \)\ + by (intro ucincl_intros) +end + \\TODO: Remove this\ lemmas ucincl_asepconj = ucincl_asepconjL @@ -633,28 +663,27 @@ proof (intro aentailsI) by (auto intro: asepconjI) qed +text \Appending \<^term>\\'\ without consuming resource requires it to hold on the +empty state:\ lemma asepconj_mono6: assumes \\ \ \'\ - and \\ \ \'\ + and \emp \ \'\ shows \\ \ \' \ \'\ -using assms asepconj_mono4 by (simp add: aentails_def asepconj_weakenI) +using assms by (simp add: aentails_def asepconj_weakenI) -lemma asepconj_mono7: - assumes \\ \ \'\ - and \ucincl \'\ - shows \\ \ \ \ \'\ -using assms by (metis aentails_true asepconj_ident2 asepconj_mono4) +\\\<^verbatim>\asepconj_mono7\ is stated with the disposal rules below.\ lemma asepconj_mono: assumes \\ \ \\ shows \\ \ \ \ \ \ \\ using asepconj_mono4 aentails_refl assms by blast +text \Weakening \<^term>\\\ to \<^term>\\ \ \\ can append only a factor +satisfied by the empty state:\ lemma asepconj_mono5: - assumes \ucincl \\ - and \\ \ \\ + assumes \emp \ \\ shows \\ \ \ \ \\ -using assms by (metis aentails_refl asepconj_mono4 asepconj_ident2) +using assms by (metis asepconj_emp_unit(1) asepconj_mono) lemma asepconj_mono3: assumes \\ = \'\ @@ -678,17 +707,134 @@ lemma asepconj_mono_sym: shows \\ \ \ \ \ \ \\ using assms by (metis asepconj_comm asepconj_mono4) -text \The following are primitive \<^emph>\cancellation\ lemmas allowing us to appeal directly to an -assumption appearing within our set of assumption in an entailment:\ +text \Discardability is the explicit licence required to forget a resource.\ +definition discardable_in :: \'a assert \ 'a assert \ bool\ where + \discardable_in \ \ \ \ \ \ \ \\ + +named_theorems discardable_in_intros + +text \\<^term>\discardable_in \ \\ means that \<^term>\\\ may be dropped +while \<^term>\\\ is retained. The relation is contextual because the retained +assertion may absorb resource owned by the discarded one. Generic rules that +produce entailment or closure obligations stay outside +\<^verbatim>\discardable_in_intros\.\ +lemma discardable_in_aentails_empI: + assumes \\ \ emp\ + shows \discardable_in \ \\ +proof - + from assms have \\ \ \ \ emp \ \\ + by (rule asepconj_mono2) + then show ?thesis + by (simp add: discardable_in_def asepconj_emp_unit(2)) +qed + +lemma discardable_in_empI [discardable_in_intros]: + shows \discardable_in emp \\ +by (rule discardable_in_aentails_empI[OF aentails_refl]) + +text \Discardability composes over separating conjunction.\ +lemma discardable_in_conj [discardable_in_intros]: + assumes \discardable_in \ \\ + and \discardable_in \ \\ + shows \discardable_in (\ \ \) \\ +proof - + from assms(2) have \\ \ \ \ \ \ \ \ \\ + by (simp add: discardable_in_def asepconj_mono) + with assms(1) show ?thesis + by (simp add: discardable_in_def asepconj_assoc aentails_trans') +qed + +lemma discardable_in_ucinclI: + assumes \ucincl \\ + shows \discardable_in \ \\ +proof - + have \\ \ \ \ \ \ \\ + by (intro asepconj_mono2 aentails_true) + then show ?thesis + by (simp add: discardable_in_def asepconj_ident assms) +qed + +text \Retaining an assertion while discarding arbitrary resource is exactly +upwards-closure.\ +lemma discardable_in_univ_iff_ucincl: + shows \discardable_in \ \ \ ucincl \\ +proof + assume \discardable_in \ \\ + have \\ \ \ \ \\ + by (rule asepconj_mono6[OF aentails_refl aentails_true]) + moreover from \discardable_in \ \\ have \\ \ \ \ \\ + by (simp add: discardable_in_def asepconj_comm) + ultimately have \\ = \ \ \\ + by (rule aentails_eq) + then show \ucincl \\ + by (simp add: ucincl_alt) +next + assume \ucincl \\ + then show \discardable_in \ \\ + by (rule discardable_in_ucinclI) +qed + +text \Cancellation consumes a discardability licence for the removed factor.\ +lemma aentails_cancel_r_discardable: + assumes \discardable_in \ \\ + shows \\ \ \ \ \\ +proof - + from assms have \\ \ \ \ \\ + by (simp add: discardable_in_def) + then show ?thesis + by (simp add: asepconj_comm) +qed + +lemma aentails_cancel_l_discardable: + assumes \discardable_in \ \\ + shows \\ \ \ \ \\ +using assms by (simp add: discardable_in_def) + +text \Upwards-closed retention is the unrestricted disposal instance.\ lemma aentails_cancel_r: assumes \ucincl \\ shows \\ \ \ \ \\ -using assms by (metis aentails_true asepconj_ident2 asepconj_mono) +using assms by (intro aentails_cancel_r_discardable discardable_in_ucinclI) lemma aentails_cancel_l: assumes \ucincl \\ shows \\ \ \ \ \\ -using assms by (metis aentails_cancel_r asepconj_comm) +using assms by (intro aentails_cancel_l_discardable discardable_in_ucinclI) + +text \For an upwards-closed retained assertion, a leading \<^term>\\\ is semantically neutral +and gives cancellation an absorber independent of factor order. The introduction form avoids +using \<^verbatim>\asepconj_ident\ backwards, which would repeatedly insert \<^term>\\\:\ +lemma aentails_insert_top: + assumes \ucincl \\ + and \\ \ \ \ \\ + shows \\ \ \\ +using assms by (simp add: asepconj_ident) + +text \Once an upwards-closed right-hand factor has been selected for +cancellation, \<^term>\\\ can be inserted immediately after that factor. +This needs upwards closure of the selected factor only, not of the remaining +right-hand conjunction.\ +lemma aentails_insert_top_after_ucincl: + assumes \ucincl \\ + and \\ \ \ \ (\ \ \)\ + shows \\ \ \ \ \\ +using assms by (simp only: asepconj_assoc[symmetric] asepconj_ident2) + +text \This rule weakens the retained factor and discards \<^term>\\\. The +\<^term>\discardable_in \ \'\ premise is the required disposal licence and remains +second so callers can compose a rule into the entailment premise.\ +lemma asepconj_mono7: + assumes \\ \ \'\ + and \discardable_in \ \'\ + shows \\ \ \ \ \'\ +proof - + from assms(1) have \\ \ \ \ \' \ \\ + by (rule asepconj_mono2) + moreover from assms(2) have \\' \ \ \ \'\ + by (rule aentails_cancel_r_discardable) + ultimately show ?thesis + by (rule aentails_trans) +qed text \The following lemmas characterise how Boolean conjunction interacts with entailment:\ lemma aentails_int [aentails_simp]: @@ -795,6 +941,12 @@ lemma awand_adjointI: shows \\ \ (\ \ \)\ using assms awand_adjoint by auto +text \A wand from the empty assertion needs no closure condition.\ +lemma awand_emp_adjointI: + assumes \\ \ \\ + shows \emp \ (\ \ \)\ +using assms by (simp add: awand_adjoint asepconj_emp_unit) + \\NOTE: This lemma is not used at present, but seems worth keeping.\ lemma aimplies_implies_awand: assumes \ucincl \\ @@ -857,10 +1009,14 @@ proof - by simp qed +text \A conditional crule rewrites \<^term>\\\ into \<^term>\\\ while +exchanging \<^term>\C0\ for \<^term>\C1\. The strong form internalises consumption +of \<^term>\C0\ in a wand. Closure is not part of either connective; derived +rules that discard an exchange residue carry their own disposal premise.\ definition aentails_conditional_crule ("_ [_]\[_] _") - where \aentails_conditional_crule \ C0 C1 \ \ C0 \ \ \ C1 \ \ \ ucincl \\ + where \aentails_conditional_crule \ C0 C1 \ \ C0 \ \ \ C1 \ \\ definition aentails_conditional_crule_strong ("_ [_]\\<^sub>s[_] _") - where \aentails_conditional_crule_strong \ C0 C1 \ \ \ \ C1 \ (C0 \ \) \ ucincl \\ + where \aentails_conditional_crule_strong \ C0 C1 \ \ \ \ C1 \ (C0 \ \)\ lemma aentails_forallL: shows \(\x. \ x) \ \ x\ @@ -875,7 +1031,6 @@ lemma awand_lambda_crule_any: \(\x0 x1 x2 x3 x4. (\4 x0 x1 x2 x3 x4 \ \4 x0 x1 x2 x3 x4)) [\4 x0 x1 x2 x3 x4]\[\4 x0 x1 x2 x3 x4] UNIV\ \(\x0 x1 x2 x3 x4 x5. (\5 x0 x1 x2 x3 x4 x5 \ \5 x0 x1 x2 x3 x4 x5)) [\5 x0 x1 x2 x3 x4 x5]\[\5 x0 x1 x2 x3 x4 x5] UNIV\ unfolding aentails_conditional_crule_def - apply (simp_all add: ucincl_UNIV) apply (all \rule asepconj_mono6[OF _ aentails_true]\) by (all \((rule aentails_trans, rule asepconj_mono[OF aentails_forallL])+)?, rule awand_counit\) @@ -894,21 +1049,35 @@ lemma aentails_conditional_crule_L0: assumes \\ [L]\[R] \\ and \UNIV \ L \ R \ G\ shows \\ \ \ \ G\ - using aentails_conditional_crule aentails_refl aentails_trans' asepconj_mono6 assms(1,2) - by blast + by (rule aentails_trans'[OF aentails_conditional_crule[OF assms] + asepconj_mono6[OF aentails_refl aentails_true]]) +text \These rules collapse the exchange residue to \<^term>\UNIV\. Their +\<^term>\ucincl \\ premise is exactly the licence +\<^term>\discardable_in \ \\ for dropping that residue.\ lemma aentails_conditional_crule_R0: assumes \\ [L]\[R] \\ and \H \ L \ R \ UNIV\ + and \ucincl \\ shows \\ \ H \ \\ - by (metis aentails_conditional_crule aentails_conditional_crule_def assms(1,2) - local.ucincl_alt) +proof - + from assms(1,2) have \\ \ H \ \ \ UNIV\ + by (rule aentails_conditional_crule) + with \ucincl \\ show ?thesis + by (simp add: asepconj_ident2) +qed lemma aentails_conditional_crule_LR0: assumes \\ [L]\[R] \\ and \UNIV \ L \ R \ UNIV\ + and \ucincl \\ shows \\ \ \\ - by (metis aentails_conditional_crule_L0 aentails_conditional_crule_def asepconj_ident2 assms(1,2)) +proof - + from assms(1,2) have \\ \ \ \ UNIV\ + by (rule aentails_conditional_crule_L0) + with \ucincl \\ show ?thesis + by (simp add: asepconj_ident2) +qed lemmas aentails_conditional_crules = aentails_conditional_crule @@ -935,9 +1104,11 @@ lemma aentails_conditional_crule_Luniv: proof - from \UNIV [L]\[R] \\ have \UNIV \ L \ \ \ R\ unfolding aentails_conditional_crule_def by (simp add: asepconj_comm) - from aentails_conditional_crule'[OF this] and assms show ?thesis - using aentails_conditional_crule_def local.ucincl_alt' - ucincl_asepconjL by blast + from aentails_conditional_crule'[OF this assms(2)] have \H \ UNIV \ \ \ G\ . + moreover have \H \ H \ UNIV\ + by (rule asepconj_mono6[OF aentails_refl aentails_true]) + ultimately show ?thesis + by (rule aentails_trans[rotated]) qed lemma aentails_conditional_crule_L0_Runiv: @@ -947,11 +1118,19 @@ lemma aentails_conditional_crule_L0_Runiv: shows \\ \ G\ by (metis aentails_conditional_crule_L0 asepconj_ident assms(1,2,3)) +text \This rule discards a \<^term>\UNIV\ residue. The \<^verbatim>\Runiv\ +variants use \<^term>\ucincl G\ for the same disposal licence.\ lemma aentails_conditional_crule_R0_Luniv: assumes \UNIV [L]\[R] \\ and \H \ L \ R \ UNIV\ + and \ucincl \\ shows \H \ \\ - by (metis aentails_conditional_crule_Luniv aentails_conditional_crule_def asepconj_ident2 assms(1,2)) +proof - + from assms(1,2) have \H \ \ \ UNIV\ + by (rule aentails_conditional_crule_Luniv) + with \ucincl \\ show ?thesis + by (simp add: asepconj_ident2) +qed lemmas aentails_conditional_crules_univ = aentails_conditional_crule_Luniv @@ -970,20 +1149,29 @@ proof - by (simp add: asepconj_comm) qed +text \Strong crules reconcile the exchange inside the wand. A degenerate +residue is therefore \<^term>\emp\ and needs no disposal premise.\ lemma aentails_conditional_crule_strong_L0: assumes \\ [L]\\<^sub>s[R] \\ and \R \ L \ G\ shows \\ \ \ \ G\ - by (smt (verit, best) aentails_conditional_crule_strong aentails_conditional_crule_strong_def - asepconj_UNIV_idempotent asepconj_ident2 asepconj_mono3 asepconj_swap_top assms(1,2) - local.ucincl_alt' ucincl_asepconjL) +proof - + from \R \ L \ G\ have \emp \ R \ L \ G\ + by (simp add: asepconj_emp_unit) + from aentails_conditional_crule_strong[OF assms(1) this] show ?thesis + by (simp add: asepconj_emp_unit) +qed lemma aentails_conditional_crule_strong_R0: assumes \\ [L]\\<^sub>s[R] \\ and \H \ R \ L\ shows \\ \ H \ \\ - using aentails_conditional_crule_strong aentails_conditional_crule_strong_def aentails_refl - asepconj_ident2 asepconj_mono6 assms(1,2) by fastforce +proof - + from \H \ R \ L\ have \H \ R \ L \ emp\ + by (simp add: asepconj_emp_unit) + from aentails_conditional_crule_strong[OF assms(1) this] show ?thesis + by (simp add: asepconj_emp_unit) +qed lemma aentails_conditional_crule_strong_LR0: assumes \\ [L]\\<^sub>s[R] \\ @@ -1165,84 +1353,122 @@ subsubsection\Pure assertions\ text \Moreing the other way, a \<^emph>\pure\ assertion is completely independent of the underlying machine. This can be modelled as an \<^emph>\embedding\ of a HOL formula into our separation logic:\ -definition apure :: \bool \ 'a assert\ (\\_\\ [0]1000) where - \\P\ \ {s. P}\ +definition apure :: \bool \ 'a assert\ where + \apure P \ {s. P}\ + +text \A precise pure assertion carries a HOL fact while owning exactly the +empty machine state.\ +definition apure_precise :: \bool \ 'a assert\ (\\_\\ [0]1000) where + \\P\ \ {s. s = 0 \ P}\ + +text \It is the ordinary pure assertion restricted to \<^term>\emp\.\ +lemma apure_precise_alt: + shows \\P\ = (apure (P) \ emp)\ +by (simp add: apure_precise_def apure_def emp_def) + +text \A precise pure assertion owns zero and is therefore discardable in +every context. A dedicated rule complements the syntactically distinct +\<^term>\emp\ rule.\ +lemma discardable_in_apure_preciseI [discardable_in_intros]: + shows \discardable_in \P\ \\ +proof (rule discardable_in_aentails_empI) + show \\P\ \ emp\ + unfolding apure_precise_alt by (rule aentails_inter_weaken[OF aentails_refl]) +qed text \The following series of lemmas describe how pure assertions interact with entailments and spatial assertions of our Separation Logic:\ lemma all_aentails_true: - shows \\ \ \True\\ + shows \\ \ apure (True)\ by (simp add: asepconj_simp apure_def aentails_true) lemma asepconj_ident3 [asepconj_simp]: assumes \ucincl \\ - shows \\ \ \True\ = \\ + shows \\ \ apure (True) = \\ by (simp add: asepconj_simp apure_def assms) lemma asepconj_ident4 [asepconj_simp]: assumes \ucincl \\ - shows \\True\ \ \ = \\ + shows \apure (True) \ \ = \\ by (simp add: asepconj_simp apure_def assms) lemma asepconj_pure [asepconj_simp]: - shows \\P\ \ \Q\ = \P \ Q\\ + shows \apure (P) \ apure (Q) = apure (P \ Q)\ by (simp add: asepconj_simp apure_def) lemma asepconj_pure2 [asepconj_simp]: - shows \\P\ \ (\Q\ \ \) = \P \ Q\ \ \\ + shows \apure (P) \ (apure (Q) \ \) = apure (P \ Q) \ \\ using asepconj_assoc asepconj_pure by metis +text \Precise pure factors combine without absorbing resource.\ +lemma asepconj_pure_precise [asepconj_simp]: + shows \\P\ \ \Q\ = \P \ Q\\ +by (auto simp add: apure_precise_def asepconj_def asat_def) + +lemma asepconj_pure2_precise [asepconj_simp]: + shows \\P\ \ (\Q\ \ \) = \P \ Q\ \ \\ +using asepconj_assoc asepconj_pure_precise by metis + lemma aentails_asepconjL_pureI: - assumes \\P \ Q\ \ \\ - shows \\P\ \ \Q\ \ \\ + assumes \apure (P \ Q) \ \\ + shows \apure (P) \ apure (Q) \ \\ using assms asepconj_pure by auto lemma aentails_asepconjL_pure2I: - assumes \\P \ Q\ \ \ \ \\ - shows \\P\ \ \Q\ \ \ \ \\ + assumes \apure (P \ Q) \ \ \ \\ + shows \apure (P) \ apure (Q) \ \ \ \\ using assms asepconj_pure2 by auto \\NOTE: This lemma is not used at present, but seems worth keeping.\ lemma aentails_asepconjR_pureI: - assumes \\ \ \P \ Q\\ - shows \\ \ \P\ \ \Q\\ + assumes \\ \ apure (P \ Q)\ + shows \\ \ apure (P) \ apure (Q)\ using assms asepconj_pure by auto \\NOTE: This lemma is not used at present, but seems worth keeping.\ lemma aentails_asepconjR_pure2I: - assumes \\ \ \P \ Q\ \ \\ - shows \\ \ \P\ \ \Q\ \ \\ + assumes \\ \ apure (P \ Q) \ \\ + shows \\ \ apure (P) \ apure (Q) \ \\ using assms asepconj_pure2 by auto lemma asepconj_pure_UNIV: - shows \\P\ \ UNIV = \P\\ and \UNIV \ \P\ = \P\\ + shows \apure (P) \ UNIV = apure (P)\ and \UNIV \ apure (P) = apure (P)\ by (metis (full_types) UNIV_def apure_def asepconj_pure)+ text \The following provides an alternative characterisation of a pure assertion, allowing us to reflect ``back and forth'' between our Separation Logic and standard HOL reasoning for pure assertions:\ lemma asat_apure_characterisation [asat_simp, simp]: - shows \x \ \P\ \ P\ + shows \x \ apure (P) \ P\ by (auto simp add: apure_def) corollary is_sat_pure [is_sat_simp, simp]: - shows \is_sat \P\ = P\ + shows \is_sat (apure P) = P\ by (simp add: asat_apure_characterisation is_sat_def) +text \Satisfaction records both the pure fact and ownership of zero.\ +lemma asat_apure_precise_characterisation [asat_simp, simp]: + shows \x \ \P\ \ x = 0 \ P\ +by (simp add: apure_precise_def asat_def) + +corollary is_sat_pure_precise [is_sat_simp, simp]: + shows \is_sat \P\ = P\ +by (simp add: asat_apure_precise_characterisation is_sat_def) + text \A pure assertion is always upwards-closed:\ lemma ucincl_apure [ucincl_intros]: - shows \ucincl \P\\ + shows \ucincl (apure P)\ by (auto simp add: apure_def intro: ucincl_intros) text \The following are technical introduction and elimination rules for working with pure assertions:\ lemma apureI: assumes \P\ - shows \s \ \P\\ + shows \s \ apure (P)\ using assms by (auto simp add: apure_def) lemma apureE: - assumes \s \ \P\\ + assumes \s \ apure (P)\ and \P \ R\ shows \R\ using assms by (clarsimp simp add: asat_simp split: if_splits) @@ -1250,53 +1476,83 @@ using assms by (clarsimp simp add: asat_simp split: if_splits) lemma asat_apure_distrib [asat_simp]: notes asat_simp [simp] assumes \ucincl \\ - shows \s \ \P\ \ \ \ P \ s \ \\ + shows \s \ apure (P) \ \ \ P \ s \ \\ proof - assume \s \ \P\ \ \\ - then obtain t u where \s = t + u\ and \t \ u\ and \t \ \P\\ and \u \ \\ + assume \s \ apure (P) \ \\ + then obtain t u where \s = t + u\ and \t \ u\ and \t \ apure (P)\ and \u \ \\ by (auto elim: asepconjE) then show \P \ s \ \\ - using \s \ \P\ \ \\ asepconj_ident3 assms local.asepconj_comm by force + using \s \ apure (P) \ \\ asepconj_ident3 assms local.asepconj_comm by force next - assume \P \ s \ \\ then show \s \ \P\ \ \\ + assume \P \ s \ \\ then show \s \ apure (P) \ \\ using asepconj_ident4 assms by auto qed lemma asat_apure_distrib2 [asat_simp]: notes asat_simp [simp] assumes \ucincl \\ - shows \s \ \ \ \P\ \ s \ \ \ P\ + shows \s \ \ \ apure (P) \ s \ \ \ P\ using asat_apure_distrib assms local.asepconj_comm by force +text \Precise-pure factors own zero, so satisfaction distributes unconditionally on either side.\ +lemma asat_apure_precise_distrib [asat_simp]: + shows \s \ \P\ \ \ \ P \ s \ \\ +by (simp add: apure_precise_def asepconj_def asat_def) + +lemma asat_apure_precise_distrib2 [asat_simp]: + shows \s \ \ \ \P\ \ s \ \ \ P\ +using asat_apure_precise_distrib local.asepconj_comm by force + lemma asat_apure_distrib': - shows \s \ \ \ \P\ \ s \ \ \ UNIV \ P\ and \s \ \P\ \ \ \ s \ UNIV \ \ \ P\ + shows \s \ \ \ apure (P) \ s \ \ \ UNIV \ P\ and \s \ apure (P) \ \ \ s \ UNIV \ \ \ P\ using apure_def asepconj_bot_zero2 asepconj_bot_zero by auto lemma asat_apure_distrib3 [asat_simp]: assumes \ucincl \\ - shows \s \ (\ \ \P\) \ \ \ s \ \ \ \ \ P\ + shows \s \ (\ \ apure (P)) \ \ \ s \ \ \ \ \ P\ using assms by (simp add: asepconj_simp asat_simp apure_def asepconj_comm) lemma asepconj_False_True: - shows \\False\ = \\ and \\True\ = \\ + shows \apure (False) = \\ and \apure (True) = \\ by (simp add: apure_def)+ +text \Truth yields the empty assertion; falsehood remains impossible.\ +lemma apure_precise_True [asepconj_simp]: + shows \\True\ = emp\ +by (simp add: apure_precise_def emp_def) + +lemma apure_precise_False [asepconj_simp]: + shows \\False\ = \\ +by (simp add: apure_precise_def) + lemma apure_entails_iff [aentails_simp]: assumes \ucincl \\ - shows \(\P\ \ \ \ \) = (P \ \ \ \)\ + shows \(apure (P) \ \ \ \) = (P \ \ \ \)\ using aentails_def asat_apure_distrib assms by blast lemma apure_entailsL0: assumes \P \ \ \ \\ - shows \\P\ \ \\ + shows \apure (P) \ \\ using assms by (simp add: asat_simp aentails_def) lemma apure_entailsL: assumes \ucincl \\ and \P \ \ \ \\ - shows \\P\ \ \ \ \\ + shows \apure (P) \ \ \ \\ +using assms by (simp add: asat_simp aentails_def) + +text \Pure assumptions can be hoisted without a closure premise; a standalone +factor leaves \<^term>\emp\ behind.\ +lemma apure_precise_entailsL0: + assumes \P \ emp \ \\ + shows \\P\ \ \\ using assms by (simp add: asat_simp aentails_def) +lemma apure_precise_entailsL: + assumes \P \ \ \ \\ + shows \\P\ \ \ \ \\ +using assms by (auto simp add: asat_simp aentails_def elim!: asepconjE) + text \The following is a variant of @\thm apure_entailsL\ which avoids an upwards-closure side-condition. The swapping of pure factors is deliberate: we typically float pure assumptions to the left and then hoist them out one by one. With the swapping, we will have a separating @@ -1304,20 +1560,26 @@ conjunction \<^verbatim>\\ \ \ \ ... \ \\ to \<^verbatim>\\ \ \=\\.\ lemma apure_entailsL': assumes \P \ \ \ \ \ \\ - shows \\P\ \ \ \ \\ + shows \apure (P) \ \ \ \\ using apure_def asepconj_comm assms bot_aentails_all by (fastforce simp add: asepconj_simp) lemma apure_entailsR0: assumes \is_sat \ \ P\ - shows \\ \ \P\\ + shows \\ \ apure (P)\ using assms by (simp add: asat_simp aentails_def is_sat_def) lemma apure_entailsR0_revE: assumes \is_sat \\ - and \\ \ \R\\ + and \\ \ apure (R)\ shows \R\ using assms by (clarsimp simp add: asat_simp aentails_def is_sat_def) +text \Only empty resource can entail a standalone precise pure assertion.\ +lemma apure_precise_entailsR0: + assumes \P\ + shows \emp \ \P\\ +using assms by (simp add: asat_simp aentails_def) + text \The following results describe how the Boolean quantifiers interact with respect to satisfiability, and can be seen as restricted forms of our previous characterisation lemma, above:\ lemma asat_existsE [elim]: @@ -1396,16 +1658,54 @@ lemma aentails_top_L': shows \\ \ \ \ \\ using assms aentails_top_L asepconj_comm by (auto intro: aentails_intro) +\\An upwards-closed conclusion can absorb a trailing \<^term>\\\. The rule stays outside +\<^verbatim>\aentails_intro\ because the sibling and conclusion licences are ambiguous from the goal.\ +lemma aentails_drop_univ_ucincl: + assumes \ucincl \\ + and \\ \ \\ + shows \\ \ \ \ \\ +using assms ucincl_alt' by blast + lemma aentails_top_R [aentails_intro]: assumes \\ \ \\ shows \\ \ \ \ \\ using assms by (metis asepconj_comm aentails_true asepconj_mono6) +lemma aentails_top_R_refl [simp]: + shows \\ \ \ \ \\ +by (rule aentails_top_R[OF aentails_refl]) + lemma aentails_top_R': assumes \\ \ \\ shows \\ \ \ \ \\ using assms aentails_top_R asepconj_comm by (auto intro: aentails_intro) +text \These rules are intended for backward use. They match a right-hand +intersection, universal, or wand preceded by \<^term>\\\ and reduce it to +the usual introduction premises without \<^term>\\\. They are more +specific than using \<^verbatim>\aentails_top_R\ as a generic final +fallback.\ +lemma aentails_intI_top: + assumes \\ \ \\ + and \\ \ \\ + shows \\ \ \ \ (\ \ \)\ +using assms by (intro aentails_top_R aentails_intI) + +lemma aforall_entailsR_top: + assumes \\x. \ \ \ x\ + shows \\ \ \ \ (\x. \ x)\ +using assms by (intro aentails_top_R aforall_entailsR) + +lemma awand_adjointI_top: + assumes \\ \ \ \ \\ + shows \\ \ \ \ (\ \ \)\ +using assms by (intro aentails_top_R awand_adjointI) + +lemma awand_emp_adjointI_top: + assumes \\ \ \\ + shows \emp \ \ \ (\ \ \)\ +using assms by (intro aentails_top_R awand_emp_adjointI) + lemma aentails_disj_distR [asepconj_simp]: shows \(a \ b) \ \ = (a \ \) \ (b \ \)\ by (intro asat_semequivI) (auto elim!: asepconjE intro: asepconjI) @@ -1451,6 +1751,11 @@ lemma awand_mp: shows \(\ \ \) \ \ \ \\ by (clarsimp elim!: asepconjE awandE simp add: aentails_def) +lemma awand_mp_strong_crule: + shows \(\ \ \) [\]\\<^sub>s[emp] \\ +unfolding aentails_conditional_crule_strong_def +by (simp add: asepconj_emp_unit aentails_refl) + lemma awand_curry: shows \(\ \ \) \ \ = \ \ \ \ \\ by (metis (no_types, lifting) aentails_eq asepconj_AC(2) awand_adjoint awand_mp) @@ -1476,6 +1781,22 @@ proof - by blast qed +text \A quantified wand family discharges one matching assertion even when carried under an +intersection with unrelated resource. Both intersection orders support symmetric call sites:\ +lemma awand_forall_inter_counit: + shows \\ r \ ((\v. \ v \ \ v) \ \) \ \ r\ + and \\ r \ (\ \ (\v. \ v \ \ v)) \ \ r\ +proof - + have wand: \(\v. \ v \ \ v) \ \ \ \ r \ \ r\ + by (intro aentails_inter_weaken2 aforall_entailsL) (rule aentails_refl) + from wand have \\ r \ ((\v. \ v \ \ v) \ \) \ \ r \ (\ r \ \ r)\ + by (rule asepconj_mono3[OF refl]) + from this show \\ r \ ((\v. \ v \ \ v) \ \) \ \ r\ + using awand_counit by (rule aentails_trans) + from this show \\ r \ (\ \ (\v. \ v \ \ v)) \ \ r\ + by (simp add: inf_commute) +qed + \\NOTE: This lemma is not used at present, but seems worth keeping.\ lemma awand_int: shows \\ \ (\ \ \) = (\ \ \) \ (\ \ \)\ @@ -1494,17 +1815,17 @@ qed \\NOTE: This lemma is not used at present, but seems worth keeping.\ lemma awand_pure_commute: assumes \ucincl \\ - shows \\\\ \ (\ \ \) \ \ \ (\\\ \ \)\ + shows \apure (\) \ (\ \ \) \ \ \ (apure (\) \ \)\ using assms by (metis (full_types) apure_entailsL aentails_cancel_l asepconj_comm asepconj_ident3 ucincl_awand) lemma awand_pure_false [asepconj_simp]: - shows \\False\ \ \ = \\ + shows \apure (False) \ \ = \\ by (subst asepconj_False_True, rule awand_bot) lemma awand_pure_true: assumes \ucincl \\ - shows \\True\ \ \ = \\ + shows \apure (True) \ \ = \\ using assms by (subst asepconj_False_True) (rule awand_univ, auto) lemma awand_curry_drule: @@ -1519,22 +1840,60 @@ using assms by (auto simp add: aentails_def intro!: asepconjI) lemma asepconj_pure': assumes \ucincl \\ - shows \\\\ \ \ = \\\ \ \\ + shows \apure (\) \ \ = apure (\) \ \\ using assms by (simp add: asepconj_simp apure_def) -lemma apure_entailsR [intro]: - assumes \\ \ \P\\ +lemma apure_entailsR: + assumes \\ \ apure (P)\ and \\ \ \\ - shows \\ \ \P\ \ \\ + shows \\ \ apure (P) \ \\ using assms by (metis aentails_def aentails_empty_R asat_apure_characterisation) +text \Splitting off an ordinary pure factor can absorb resource. The +restricted rule permits this only when the retained assertion is +upwards-closed; its closure premise is a policy guard, not proof input. +Neither ordinary rule is an introduction rule, so automation cannot discard +resource implicitly.\ +lemma apure_entailsR_restricted: + assumes pure: \\ \ apure (P)\ + and ent: \\ \ \\ + and \ucincl \\ + shows \\ \ apure (P) \ \\ +using pure ent by (rule apure_entailsR) + +text \A precise pure factor splits off without receiving any resource, so +this rule remains available to introduction search.\ +lemma apure_precise_entailsR [intro]: + assumes \is_sat \ \ P\ + and ent: \\ \ \\ + shows \\ \ \P\ \ \\ +proof (rule aentails_is_sat) + assume \is_sat \\ + with assms(1) have \0 \ \P\\ + by simp + from this and ent show \\ \ \P\ \ \\ + by (rule aentails_empty_R) +qed + +text \This variant leaves the pure premise as a separating entailment, so +later spatial drule and rule branches can continue solving it.\ +lemma apure_precise_entailsR': + assumes pure: \\ \ apure (P)\ + and ent: \\ \ \\ + shows \\ \ \P\ \ \\ +proof (rule apure_precise_entailsR[OF _ ent]) + assume \is_sat \\ + from this and pure show \P\ + by (rule apure_entailsR0_revE) +qed + lemma aentails_asepconj_split_true: assumes \ucincl \\ and \\ \ \\ - and \\True\ \ \\ + and \apure (True) \ \\ shows \\ \ \ \ \\ proof - - from assms have \\ \ \True\ \ \ \ \\ + from assms have \\ \ apure (True) \ \ \ \\ using asepconj_mono4 by blast from assms this show ?thesis using asepconj_ident3 by auto @@ -1562,14 +1921,14 @@ qed text \The following are technical results that allow fine-grained control over proof-steps in Separation Logic entailment proofs:\ lemma aentails_cut_pure: - assumes \\ \ \P\\ + assumes \\ \ apure (P)\ and \P \ \ \ \\ shows \\ \ \\ using assms by (clarsimp simp add: aentails_def apure_def asat_def split: if_splits) lemma aentails_frulify_pure: - assumes \\ \ \P\\ - shows \\ \ \ \ \P\\ + assumes \\ \ apure (P)\ + shows \\ \ \ \ apure (P)\ by (metis aentails_refl apure_entailsR asepconj_comm assms) lemma aentails_fold_def: @@ -1592,7 +1951,10 @@ definition asepconj_multi' :: \'a assert multiset \ 'a assert \asepconj_multi' \ \ \ fold_mset asepconj \ \\ definition asepconj_multi :: \'a assert multiset \ 'a assert\ ("\\") where - \asepconj_multi \ \ asepconj_multi' \ UNIV\ + \asepconj_multi \ \ asepconj_multi' \ emp\ + +text \The \<^term>\emp\ fold unit makes an iterated conjunction own exactly its factors; the empty +iteration owns zero.\ text \Iterated separating conjunction preserves upwards-closure:\ lemma asepconj_multi'_ucincl [ucincl_intros]: @@ -1601,11 +1963,33 @@ lemma asepconj_multi'_ucincl [ucincl_intros]: shows \ucincl (\ \\\ \)\ using 1 by (induction \) (auto simp: 2 asepconj_multi'_def local.ucincl_asepconjL) +text \A non-empty iteration of upwards-closed factors is upwards closed. Both premises are +determined by the conclusion, so the rule participates in closure search.\ corollary asepconj_multi_ucincl [ucincl_intros]: fixes \ :: \'a assert multiset\ - assumes \\\. \ \# \ \ ucincl \\ + assumes \\ \ {#}\ + and \\\. \ \# \ \ ucincl \\ shows \ucincl (\\\)\ -using assms by (auto simp add: ucincl_UNIV asepconj_multi_def asepconj_multi'_ucincl) +proof - + from assms(1) obtain \ \ where \\ = add_mset \ \\ + by (metis multiset_cases) + with assms(2) show ?thesis + by (simp add: asepconj_multi_def asepconj_multi'_def local.ucincl_asepconjL) +qed + +text \One upwards-closed member suffices, but its witness is not determined by the conclusion, so +this sharper rule stays outside \<^verbatim>\ucincl_intros\.\ +corollary asepconj_multi_ucincl_member: + fixes \ :: \'a assert multiset\ + assumes \\ \# \\ + and \ucincl \\ + shows \ucincl (\\\)\ +proof - + from assms(1) obtain \ where \\ = add_mset \ \\ + by (metis multi_member_split) + with assms(2) show ?thesis + by (simp add: asepconj_multi_def asepconj_multi'_def local.ucincl_asepconjL) +qed text \The following are generalisations of identity, symmetric, and associativity results for the standard separating conjunction to the iterated separating conjunction:\ @@ -1614,8 +1998,12 @@ lemma asepconj_multi'_empty [asepconj_simp]: shows \{#} \\\ \ = \\ by (auto simp add: asepconj_multi_def asepconj_multi'_def) +lemma asepconj_multi'_add_mset [asepconj_simp]: + shows \(add_mset \ \) \\\ \ = \ \ (\ \\\ \)\ +by (simp add: asepconj_multi'_def ASepConjComm.fold_mset_add_mset) + lemma asepconj_multi_empty [asepconj_simp]: - shows \\\{#} = UNIV\ + shows \\\{#} = emp\ by (auto simp add: asepconj_multi_def asepconj_multi'_def) lemma asepconj_multi_split: @@ -1631,26 +2019,23 @@ lemma asepconj_multi_single [asepconj_simp]: shows \{# \ #} \\\ \ = \ \ \\ by (clarsimp simp add: asepconj_multi_def asepconj_multi'_def; auto) -text \An upwards-closed, singleton assertion can be ``projected out'' of an iterated separating -conjunction\ +text \A singleton iteration is exactly its factor.\ lemma asepconj_multi_single' [asepconj_simp]: - assumes \ucincl \\ - shows \\\{# \ #} = \\ -using assms by (simp add: asepconj_simp asepconj_multi_def) + shows \\\{# \ #} = \\ +by (simp add: asepconj_simp asepconj_multi_def) lemma asepconj_multi_assoc0: shows \(\ \\\ \) \ \ = \ \\\ (\ \ \)\ by (force simp add: ASepConjComm.fold_mset_fun_left_comm asepconj_comm asepconj_multi'_def) +text \An explicit starting value is a trailing conjunct of the exact fold.\ lemma asepconj_multi_multi': - assumes \ucincl \\ - shows \(\\ \) \ \ = \ \\\ \\ (is ?Goal) - by (simp add: asepconj_multi_assoc0 asepconj_multi_def assms local.asepconj_ident) + shows \(\\ \) \ \ = \ \\\ \\ + by (simp add: asepconj_multi_assoc0 asepconj_multi_def local.asepconj_emp_unit(2)) lemma asepconj_multi_split' [asepconj_simp]: shows \\\ (\ + \) = \\ \ \ \\ \\ -by (simp add: asepconj_simp ASepConjComm.fold_mset_fun_left_comm asepconj_comm asepconj_multi'_def - asepconj_multi_def) +by (metis asepconj_multi_def asepconj_multi_multi' asepconj_multi_split) \\NOTE: This lemma is not used at present, but seems worth keeping.\ lemma asepconj_multi_split'': @@ -1658,6 +2043,24 @@ lemma asepconj_multi_split'': shows \\\ \ = \\ \ \ \\ (\ - \)\ by (metis asepconj_multi_split' assms subset_mset.add_diff_inverse) +text \An iterated conjunction is discardable when every factor is discardable.\ +lemma discardable_in_multi [discardable_in_intros]: + assumes \\\. \ \# \ \ discardable_in \ \\ + shows \discardable_in (\\\) \\ +using assms proof (induction \) + case empty + then show ?case + by (simp add: asepconj_simp discardable_in_empI) +next + case (add \ \) + from add have 1: \discardable_in \ \\ and 2: \discardable_in (\\\) \\ + by auto + have \\\(add_mset \ \) = \ \ \\\\ + by (simp add: asepconj_multi_def asepconj_multi'_add_mset) + with 1 2 show ?case + by (simp add: discardable_in_conj) +qed + lemma is_sat_multiE[is_sat_elim]: assumes \is_sat (\\{# \ . ms #})\ and \(\x. x \# ms \ is_sat (\ x)) \ R\ @@ -1672,9 +2075,18 @@ context sepalg begin (*>*) corollary asepconj_multi_mapped_ucincl [ucincl_intros]: - assumes \\r. ucincl (e r)\ + assumes \m \ {#}\ + and \\r. ucincl (e r)\ + shows \ucincl (\\ {# e . m #})\ +using assms by (intro asepconj_multi_ucincl) auto + +\\This sharper form stays outside \<^verbatim>\ucincl_intros\ because its witness is not +determined by the conclusion.\ +corollary asepconj_multi_mapped_ucincl_member: + assumes \r \# m\ + and \ucincl (e r)\ shows \ucincl (\\ {# e . m #})\ -by (metis assms local.asepconj_multi_ucincl msed_map_invR multi_member_split) +using assms by (intro asepconj_multi_ucincl_member[where \=\e r\]) auto text \The following technical result is at the heart of the cancellation tactic for iterated separating conjunctions. Before it is applied, it should be ensured that all separating @@ -1683,9 +2095,10 @@ conjunction components of the form \<^term>\\\{# e . ms #}\ms' \# ms\ and \\r. ucincl (e r)\ + and \ms' \ {#}\ shows \\\ {# e . ms #} \ \\ {# e . ms' #}\ using assms by (metis aentails_cancel_r asepconj_multi_mapped_ucincl asepconj_multi_split' - image_mset_union subset_mset.le_iff_add) + image_mset_is_empty_iff image_mset_union subset_mset.le_iff_add) text \The following results are useful when trying to show entailments between iterated separating conjunctions:\ @@ -1718,12 +2131,12 @@ qed lemma aentails_cancel_multi_0L: assumes \\\{# e . ms' - ms #} \ \\{# e . (ms - ms') #} \ \'\ shows \\\{# e . ms' #} \ \\{# e . ms #} \ \'\ -using aentails_cancel_multi by (metis assms asepconj_multi_def asepconj_multi_multi' ucincl_UNIV) +using aentails_cancel_multi by (metis assms local.asepconj_emp_unit(1)) lemma aentails_cancel_multi_0R: assumes \\\{# e . ms' - ms #} \ \ \ \\{# e . (ms - ms') #}\ shows \\\{# e . ms' #} \ \ \ \\{# e . ms #}\ -using aentails_cancel_multi by (metis assms asepconj_multi_def asepconj_multi_multi' ucincl_UNIV) +using aentails_cancel_multi by (metis assms local.asepconj_emp_unit(1)) lemma asepconj_add_mset [simp]: shows \\\(add_mset x xs) = x \ \\xs\ @@ -1739,18 +2152,21 @@ lemma asepconj_multi_mapped_pick: shows \\\{# \ \ lst #} = \ (lst ! i) \ \\{# \ \ drop_nth i lst #}\ using assms by (metis asepconj_multi_cons list_update_id mset.simps(2) mset_drop_nth' mset_update) +text \An iteration of ordinary pure assertions collapses to \<^term>\emp\ when empty and to one pure +assertion otherwise.\ +lemma asepconj_multi_pure: + shows \\\{# apure (P x) . x\ms #} = (if ms = {#} then emp else apure (\x \# ms. P x))\ +by (induction ms; auto simp add: asepconj_simp apure_def) + +text \Precise-pure assertions collapse uniformly because \<^term>\\True\ = emp\.\ +lemma asepconj_multi_pure_precise: + shows \\\{# \P x\ . x\ms #} = \\x \# ms. P x\\ +by (induction ms; simp add: asepconj_simp) + \\NOTE: This lemma is not used at present, but seems worth keeping.\ lemma aentails_multi_list_pure: - shows \\\{# \f x\ \ x \ xs #} = \\x \ set xs. f x\\ -proof (induction xs) - case Nil - then show ?case - using local.apure_def local.asepconj_multi_empty by force -next - case (Cons a xs) - then show ?case - by (simp add: asepconj_simp local.apure_def) -qed + shows \\\{# apure (f x) \ x \ xs #} = (if xs = [] then emp else apure (\x \ set xs. f x))\ +by (simp add: asepconj_multi_pure) lemma aentails_multi_list_pointwise: notes asepconj_simp [simp] aentails_intro [intro] @@ -1823,27 +2239,28 @@ lemma aentails_multi_list_pointwise_fixed_indexing': shows \\\{# f . xs #} \ \\{# g . xs #}\ using assms by (induction xs) (auto intro: asepconj_mono4 aentails_intro) +text \Dropping factors requires the retained iteration to be non-empty and upwards closed.\ lemma aentails_multi_list_pointwise_fixed_indexing'': assumes \ys \# xs\ and \\x. x \# xs \ f x \ g x\ + and \ys \ {#}\ + and \\y. ucincl (g y)\ shows \\\{# f . xs #} \ \\{# g . ys #}\ using assms proof - have \\\{# f . xs #} \ \\{# g . xs #}\ using assms by (simp add: aentails_multi_list_pointwise_fixed_indexing') also have \\ \ \\{# g . ys #}\ - using assms by (metis image_mset_union local.aentails_cancel_r local.asepconj_ident4 - local.asepconj_multi_assoc0 local.asepconj_multi_def local.asepconj_multi_split' - local.ucincl_UNIV local.ucincl_asepconjR subset_mset.less_eqE) + using assms by (intro aentails_multi_subset) finally show ?thesis by blast qed lemma aentails_multi_list_pointwise_fixed_indexing''': assumes \\x. x\# xs \ f x \ g x\ - and \\True\ \ \\ + and \emp \ \\ shows \\\{# f . xs #} \ \\{# g . xs #} \ \\ -using assms by (metis aentails_eq aentails_multi_list_pointwise_fixed_indexing' - all_aentails_true apure_entailsR asepconj_comm) +using assms by (meson aentails_multi_list_pointwise_fixed_indexing' aentails_trans' + local.asepconj_mono5) lemma aentails_multi_mapped_pick: assumes \i < length lst\ @@ -1857,69 +2274,59 @@ lemma aentails_multi_mapped_pick_0L: shows \\\{# \ \ lst #} \ \\ using asepconj_multi_mapped_pick assms asepconj_assoc by metis -\\NOTE: This lemma is not used at present, but seems worth keeping.\ -lemma asepconj_multi_hoist_pure: - assumes 0: \\x. ucincl (\ x)\ - and 1: \ms \ {#}\ - shows \\P\ \ \\{# \ x . x \ ms #} = \\{# (\ x \ \P\) . x \ ms #}\ - using 1 -proof (induction ms) - case empty - then show ?case by auto -next - case (add x ms) - then show ?case - proof (cases \ms = {#}\) - case True - then show ?thesis - by (simp add: local.asepconj_comm local.asepconj_swap_top) - next - case False - with add have \\P\ \ \\ {# \ . ms #} = \\ {# \ x \ \P\ . x \ ms #}\ - by linarith - with 0 have \\P\ \ \\ {# \ . add_mset x ms #} = \\ {# \ x \ \P\ . x \ add_mset x ms #}\ - by (auto simp: asepconj_simp asepconj_swap_top apure_def asepconj_multi_mapped_ucincl) - then show ?thesis - by blast - qed -qed - lemma asepconj_multi_split_body: shows \\\{# \s. (\ s \ \ s) . ms #} = \\{# \ s . s \ ms #} \ \\{# \ s . s \ ms #}\ proof (induction ms) case empty then show ?case - by (simp add: asepconj_UNIV_idempotent asepconj_multi_empty) + by (simp add: local.asepconj_emp_unit(1) asepconj_multi_empty) next case (add x ms) then show ?case by (simp add: asepconj_assoc asepconj_swap_top) qed +text \An ordinary pure factor can be copied into every member of a non-empty iteration because it +is idempotent under \<^term>\(\)\.\ +lemma asepconj_multi_hoist_pure: + assumes \ms \ {#}\ + shows \apure (P) \ \\{# \ x . x \ ms #} = \\{# (\ x \ apure (P)) . x \ ms #}\ +proof - + have nonempty: \\x. x \# ms\ + using assms by auto + have \\\{# (\ x \ apure (P)) . x \ ms #} = + \\{# \ x . x \ ms #} \ \\{# apure (P) . x \ ms #}\ + by (rule asepconj_multi_split_body) + also from nonempty have \\\{# apure (P) . x \ ms #} = apure (P)\ + by (simp add: asepconj_multi_pure assms) + finally show ?thesis + by (simp add: local.asepconj_comm) +qed + lemma asepconj_union_singleton: assumes \\x. ucincl (\ x)\ - shows \(\x. (\x = y\ \ \ x)) = \ y\ + shows \(\x. (apure (x = y) \ \ x)) = \ y\ proof (intro aentails_eq) - show \(\x. \x = y\ \ \ x) \ \ y\ + show \(\x. apure (x = y) \ \ x) \ \ y\ by (simp add: aentails_refl assms aexists_entailsL apure_def asepconj_bot_zero asepconj_ident bot_aentails_all) next have \\ y \ \ y\ by (rule aentails_refl) - moreover from this assms have \\ y \ \y = y\ \ \ y\ + moreover from this assms have \\ y \ apure (y = y) \ \ y\ using local.asepconj_ident4 by auto - ultimately show \\ y \ (\x. \x = y\ \ \ x)\ + ultimately show \\ y \ (\x. apure (x = y) \ \ x)\ using local.aexists_entailsR by fastforce qed \\NOTE: This lemma is not used at present, but seems worth keeping.\ lemma asepconj_union_singleton': assumes \\x y. ucincl (\ x y)\ - shows \(\a b. (\a=t\ \ \ a b)) = (\b. \ t b)\ + shows \(\a b. (apure (a=t) \ \ a b)) = (\b. \ t b)\ proof - from assms have A: \\a. ucincl (\b. \ a b)\ by (intro ucincl_intros) blast - moreover have \(\a b. (\a=t\ \ \ a b)) = (\a. (\a=t\ \ (\b. \ a b)))\ + moreover have \(\a b. (apure (a=t) \ \ a b)) = (\a. (apure (a=t) \ (\b. \ a b)))\ using asepconj_Inf_distrib2 asepconj_comm by (clarsimp simp add: local.asepconj_Inf_distrib2) moreover from A have \... = (\b. \ t b)\ @@ -1929,7 +2336,7 @@ proof - qed lemma asepconj_Union_pure: - shows \(\x. \P x\) = \\x. P x\\ + shows \(\x. apure (P x)) = apure (\x. P x)\ by (clarsimp simp add: apure_def) lemma aentails_multi_map_core: @@ -1971,78 +2378,64 @@ lemma aentails_multi_map_core': using aentails_multi_map_core by metis corollary asepconj_mset_map_sum_lift_single: - shows \\add_mset x ms0 = (f `# ms')\ = (\x' ms0'. \ms' = add_mset x' ms0'\ \ \x = f x'\ \ - \ms0 = (f `# ms0')\)\ + shows \apure (add_mset x ms0 = (f `# ms')) = (\x' ms0'. apure (ms' = add_mset x' ms0') \ apure (x = f x') \ + apure (ms0 = (f `# ms0')))\ by (clarsimp simp add: asepconj_simp asepconj_Union_pure mset_map_sum_lift_single) +text \Distributing existential choices records one witness per index. The index constraint is +precise-pure so both sides own the same resource.\ lemma asepconj_multi_Union: - assumes \\x y. ucincl (\ x y)\ - shows \\\{# (\x. \ s x) . s \ idxs #} = - (\idxs'. \idxs = (fst `# idxs')\ \ \\{# \ (fst t) (snd t) . t \ idxs' #})\ + shows \\\{# (\x. \ s x) . s \ idxs #} = + (\idxs'. \idxs = (fst `# idxs')\ \ \\{# \ (fst t) (snd t) . t \ idxs' #})\ proof (induction idxs) case empty - then show ?case - using local.apure_def local.asepconj_multi_empty local.asepconj_multi_single' by auto -next - case IH: (add x idxs) - have \\ x u \ \\ {# \ (range (\ s)) . s \ idxs #} \ - (\idxs'. \add_mset x idxs = {# fst . idxs' #}\ \ \\ {# \ (fst t) (snd t) . t \ idxs' #})\ for u - proof - - have \\idxs = {# fst . v #}\ \ \\ {# \ (fst t) (snd t) . t \ v #} \ \ x u \ - (\idxs'. \add_mset x idxs = {# fst . idxs' #}\ \ \\ {# \ (fst t) (snd t) . t \ idxs' #})\ for v - proof - - have \\idxs = {# fst . v #}\ \ \\ {# \ (fst t) (snd t) . t \ v #} \ \ x u \ - \add_mset (x, u) v = add_mset (x, u) v \ idxs = {# fst . v #}\ \ - \ x u \ \\ {# \ (fst t) (snd t) . t \ v #}\ - by (clarsimp simp add: aentails_refl asepconj_comm) - then have \\idxs = {# fst . v #}\ \ \\ {# \ (fst t) (snd t) . t \ v #} \ \ x u \ (\xc xd. - \add_mset (x, u) v = add_mset xc xd \ x = fst xc \ idxs = {# fst . xd #}\ \ - \ x u \ \\ {# \ (fst t) (snd t) . t \ v #})\ - by (smt (verit) fst_conv local.aexists_entailsR) - then have \\idxs = {# fst . v #}\ \ \\ {# \ (fst t) (snd t) . t \ v #} \ \ x u \ ( - (\x' ms0'. \v + {# (x, u) #} = add_mset x' ms0'\ \ \x = fst x'\ \ \idxs = {# fst . ms0' #}\) \ - \\ {# \ (fst t) (snd t) . t \ v + {# (x, u) #} #})\ - by (clarsimp simp add: asepconj_simp) - then have \\idxs = {# fst . v #}\ \ \\ {# \ (fst t) (snd t) . t \ v #} \ \ x u \ (\idxs'. - (\x' ms0'. \idxs' = add_mset x' ms0'\ \ \x = fst x'\ \ \idxs = {# fst . ms0' #}\) \ - \\ {# \ (fst t) (snd t) . t \ idxs' #})\ - by (rule aexists_entailsR) - then show ?thesis - by (force simp add: asepconj_mset_map_sum_lift_single) + show ?case + proof (intro aentails_eq) + show \\\{# (\x. \ s x) . s \ {#} #} \ + (\idxs'. \{#} = (fst `# idxs')\ \ \\{# \ (fst t) (snd t) . t \ idxs' #})\ + by (rule aexists_entailsR[of _ _ \{#}\]) (simp add: asepconj_simp aentails_refl) + next + show \(\idxs'. \{#} = (fst `# idxs')\ \ \\{# \ (fst t) (snd t) . t \ idxs' #}) \ + \\{# (\x. \ s x) . s \ {#} #}\ + proof (intro aexists_entailsL) + fix idxs' show \\{#} = (fst `# idxs')\ \ \\{# \ (fst t) (snd t) . t \ idxs' #} \ + \\{# (\x. \ s x) . s \ {#} #}\ + by (cases \idxs' = {#}\) + (auto simp add: asepconj_simp aentails_refl bot_aentails_all) qed - then have \\ x u \ (\idxs'. \idxs = {# fst . idxs' #}\ \ \\ {# \ (fst t) (snd t) . t \ idxs' #}) - \ (\idxs'. \add_mset x idxs = {# fst . idxs' #}\ \ \\ {# \ (fst t) (snd t) . t \ idxs' #})\ - by (simp add: local.aexists_entailsL local.asepconj_Inf_distrib3 local.asepconj_assoc) - with IH show ?thesis - by auto qed - then have \(\u. \ x u \ \\ {# \ (range (\ s)) . s \ idxs #}) \ - (\idxs'. \add_mset x idxs = {# fst . idxs' #}\ \ \\ {# \ (fst t) (snd t) . t \ idxs' #})\ - by (intro aexists_entailsL) - moreover - have \\add_mset x idxs = {# fst . idxs' #}\ \ \\ {# \ (fst t) (snd t) . t \ idxs' #} \ - (\xa. \ x xa \ \\ {# \ (range (\ s)) . s \ idxs #})\ for idxs' - proof - - have \\idxs' = add_mset u v \ x = fst u \ idxs = {# fst . v #}\ \ \\ {# \ (fst t) (snd t) . t \ idxs' #} \ - (\u v. \idxs = {# fst . v #}\ \ \\ {# \ (fst t) (snd t) . t \ v #} \ \ x u)\ for u v - by (force simp add: asepconj_simp apure_def aentails_refl asepconj_comm bot_aentails_all intro: aentails_refl local.aexists_entailsR) - then have \(\u v. \idxs' = add_mset u v \ x = fst u \ idxs = {# fst . v #}\ \ \\ {# \ (fst t) (snd t) . t \ idxs' #}) \ - (\u v. \idxs = {# fst . v #}\ \ \\ {# \ (fst t) (snd t) . t \ v #} \ \ x u)\ - by (force intro: aexists_entailsL) - then have \\add_mset x idxs = {# fst . idxs' #}\ \ \\ {# \ (fst t) (snd t) . t \ idxs' #} \ - (\xa. \ x xa \ (\idxs'. \idxs = {# fst . idxs' #}\ \ \\ {# \ (fst t) (snd t) . t \ idxs' #}))\ - by (subst asepconj_mset_map_sum_lift_single) (clarsimp simp add: asepconj_simp) - with IH show ?thesis - by auto +next + case IH: (add s idxs) + show ?case (is \?lhs = ?rhs\) + proof (intro aentails_eq, goal_cases) + case 1 + have step1: \?lhs \ (\x. \ s x) \ + (\r. \idxs = (fst `# r)\ \ \\{# \ (fst t) (snd t) . t \ r #})\ + by (simp add: IH aentails_refl asepconj_add_mset) + have step2: \\ s x \ \idxs = (fst `# r)\ \ + \\{# \ (fst t) (snd t) . t \ r #} \ ?rhs\ for x r + using asepconj_assoc asepconj_comm + by (rule_tac aexists_entailsR[of _ _ \add_mset (s, x) r\]) (simp add: aentails_refl) + show ?case + by (rule aentails_trans[OF step1]) + (auto intro!: aexists_entailsL aentails_trans[OF step2] aentails_refl + simp add: asepconj_Inf_distrib_right asepconj_Inf_distrib) + next + case 2 + have step: \\add_mset s idxs = (fst `# idxs')\ \ + \\{# \ (fst t) (snd t) . t \ idxs' #} \ ?lhs\ for idxs' + proof (cases \(fst `# idxs') = add_mset s idxs\) + case True + then obtain w r where \idxs' = add_mset (s, w) r\ and \(fst `# r) = idxs\ + using msed_map_invR by fastforce + then show ?thesis + by (auto simp add: asepconj_simp IH asepconj_Inf_distrib asepconj_Inf_distrib_right + aentails_refl + intro!: aexists_entailsR[of _ _ r] aexists_entailsR[of _ _ w]) + qed (simp add: asepconj_simp bot_aentails_all) + show ?case + by (auto intro!: aexists_entailsL step simp only:) qed - then have \(\idxs'. \add_mset x idxs = {# fst . idxs' #}\ \ \\ {# \ (fst t) (snd t) . t \ idxs' #}) \ - (\xa. \ x xa \ \\ {# \ (range (\ s)) . s \ idxs #})\ - by (intro aexists_entailsL) - ultimately have \(\xa. \ x xa \ \\ {# \ (range (\ s)) . s \ idxs #}) = - (\idxs'. \add_mset x idxs = {# fst . idxs' #}\ \ \\ {# \ (fst t) (snd t) . t \ idxs' #})\ - by (force intro!: aentails_eq) - then show ?case - by (auto simp add: asepconj_simp) qed lemma aentails_multi_map: @@ -2051,82 +2444,65 @@ lemma aentails_multi_map: shows \\\{# \ . ms #} = \\{# \' . ms' #}\ using assms aentails_multi_map_core by blast -text\This is an \<^emph>\Axiom of Choice\ style result for iterated separating conjunctions:\ -\\NOTE: This lemma is not used at present, but seems worth keeping.\ -lemma asepconj_multi_Union_set: - assumes \finite idxs\ - and \\x y. ucincl (\ x y)\ - shows \\\{# (\x. \ s x) . s \ mset_set idxs #} = (\f. \\{# \ s (f s) . s \ mset_set idxs #})\ -proof - - have \(\x. \idxs = fst ` x \ inj_on fst x\ \ \\ {# \ (fst t) (snd t) . t \ mset_set x #}) = - (\x. \idxs = fst ` x\ \ \inj_on fst x\ \ \\ {# \ (fst t) (snd t) . t \ mset_set x #})\ - by (clarsimp simp add: asepconj_simp) - also have \\ = (\x xa. \xa = mset_set x\ \ \idxs = fst ` x\ \ \inj_on fst x\ \ - \\ {# \ (fst t) (snd t) . t \ xa #})\ - by (force simp add: asepconj_union_singleton ucincl_intros) - also have \\ = (\x xa. \x = mset_set xa\ \ \idxs = fst ` xa\ \ \inj_on fst xa\ \ - \\ {# \ (fst t) (snd t) . t \ x #})\ - by (subst set_Union_flip, rule refl) - also have \\ = (\x xa. \x = mset_set xa \ idxs = fst ` xa \ inj_on fst xa\ \ - \\ {# \ (fst t) (snd t) . t \ x #})\ - by (clarsimp simp flip: asepconj_pure asepconj_assoc) - also have \\ = (\x. (\xa. \x = mset_set xa \ idxs = fst ` xa \ inj_on fst xa\) \ - \\ {# \ (fst t) (snd t) . t \ x #})\ - by (clarsimp simp add: asepconj_simp) - also have \\ = (\x. \mset_set idxs = {# fst . x #}\ \ \\ {# \ (fst t) (snd t) . t \ x #})\ - using assms by (force simp add: asepconj_Union_pure mset_set_tagged) - also have \\ = \\ {# \ (range (\ s)) . s \ mset_set idxs #}\ - using assms by (clarsimp simp add: asepconj_multi_Union) - finally have A: \(\x. \idxs = fst ` x \ inj_on fst x\ \ - \\ {# \ (fst t) (snd t) . t \ mset_set x #}) = \\ {# \ (range (\ s)) . s \ mset_set idxs #}\ +text\The following says that a multiset of pairs whose first components exhaust a \<^emph>\set\ is in fact +``functional'': it is the graph of a function on that set.\ +lemma multi_set_set_functionality: + fixes M ME + assumes \mset_set M = (fst `# ME)\ + shows \\f. ME = {# (m, f m) . m \ mset_set M #}\ +using assms proof (induction ME arbitrary: M) + case empty + then show ?case + by simp +next + case (add x ME) + note IH = this + have \finite M \ infinite M\ + by simp + then have \finite M\ + using IH(2) by force + then have dist: \mset_set M = add_mset (fst x) (mset_set (M - {fst x}))\ + using IH(2) elem_mset_set Multiset.mset_set.remove by fastforce + then have IHprem: \mset_set (M - {fst x}) = (fst `# ME)\ + by (simp add: IH(2)) + with \finite M\ have \fst ` set_mset ME = M - {fst x}\ + by (metis finite_Diff finite_set_mset_mset_set multiset.set_map) + then have fst_ineq: \\y. y \ fst ` set_mset ME \ y \ fst x\ by blast - have B: \\\ {# \ (fst t) (snd t) . t \ mset_set x #} \ - \\ {# \ s (map_from_graph x s) . s \ mset_set (fst ` x) #}\ - if x: \idxs = fst ` x\ \inj_on fst x\ - for x :: \('b \ 'c) set\ - proof - - have \mset_set (fst ` x) = (fst `# mset_set x)\ - using that by (simp add: image_mset_mset_set) - moreover - have \\ (fst y) (snd y) \ \ (fst y) (map_from_graph x (fst y))\ - if \y \# mset_set x\ for y - by (metis x aentails_refl assms(1) finite_imageD - finite_set_mset_mset_set map_from_graph_eval' that) - then have \\\ {# \ (fst t) (snd t) . t \ mset_set x #} \ - \\ {# \ (fst xa) (map_from_graph x (fst xa)) . xa \ mset_set x #}\ - by (intro aentails_multi_list_pointwise_fixed_indexing') - then have \\\ {# \ (fst t) (snd t) . t \ mset_set x #} \ - \\ {# \ s (map_from_graph x s) . s \ {# fst . mset_set x #} #}\ - by (simp add: aentails_multi_map_core') - ultimately show ?thesis - by clarsimp - qed - have \\idxs = fst ` x \ inj_on fst x\ \ \\ {# \ (fst t) (snd t) . t \ mset_set x #} \ - (\f. \\ {# \ s (f s) . s \ mset_set idxs #})\ for x - proof - - have \\idxs = fst ` x \ inj_on fst x\ \ \\ {# \ (fst t) (snd t) . t \ mset_set x #} \ - \\ {# \ s (map_from_graph x s) . s \ mset_set idxs #}\ - using B local.apure_entailsL' local.asepconj_multi_def local.asepconj_multi_multi' by auto + obtain f where \ME = {# (m, f m) . m \ mset_set (M - {fst x}) #}\ + using IH IHprem by force + moreover let ?f' = \\y. if y \ fst x then f y else snd x\ + from calculation have \add_mset x ME = {# (m, ?f' m) . m \ mset_set M #}\ + by (simp add: dist) (force intro!: image_mset_cong simp add: IHprem fst_ineq) + ultimately show ?case + by force +qed + +text\The set-indexed choice law follows by representing the witness multiset as a function +graph.\ +lemma asepconj_multi_Union_set: + shows \\\{# (\x. \ s x) . s \ mset_set idxs #} = + (\f. \\{# \ s (f s) . s \ mset_set idxs #})\ +proof (simp add: asepconj_multi_Union, intro aentails_eq aexists_entailsL, goal_cases) + case (1 x) + show ?case + proof (cases \(fst `# x) = mset_set idxs\) + case True + obtain f where \x = {# (m, f m) . m \ mset_set idxs #}\ + using multi_set_set_functionality[OF True[symmetric]] by blast then show ?thesis - by (auto intro: aexists_entailsR) - qed - then have C: \(\x. \idxs = fst ` x \ inj_on fst x\ \ - \\ {# \ (fst t) (snd t) . t \ mset_set x #}) \ (\f. \\ {# \ s (f s) . s \ mset_set idxs #})\ - by (auto intro: aexists_entailsL) - moreover - have \\\ {# \ s (f s) . s \ mset_set idxs #} \ - (\x. \idxs = fst ` x \ inj_on fst x\ \ \\ {# \ (fst t) (snd t) . t \ mset_set x #})\ - for f :: \'b \ 'c\ - by (metis (no_types, lifting) A aentails_multi_list_pointwise_fixed_indexing' aentails_refl aexists_entailsR) - then have \(\f. \\ {# \ s (f s) . s \ mset_set idxs #}) \ - (\x. \idxs = fst ` x \ inj_on fst x\ \ \\ {# \ (fst t) (snd t) . t \ mset_set x #})\ - by (intro aexists_entailsL) - then have \(\f. \\ {# \ s (f s) . s \ mset_set idxs #}) = - (\x. \idxs = fst ` x \ inj_on fst x\ \ \\ {# \ (fst t) (snd t) . t \ mset_set x #})\ - by (simp add: aentails_eq C) - ultimately show \\\ {# \ (range (\ s)) . s \ mset_set idxs #} = - (\f. \\ {# \ s (f s) . s \ mset_set idxs #})\ - using A by auto + apply (simp only: True[symmetric] HOL.refl apure_precise_True asepconj_emp_unit) + apply (rule aexists_entailsR[of _ _ f]) + by (metis (mono_tags, lifting) aentails_multi_map aentails_refl_eq split_pairs) + qed (simp add: asepconj_simp bot_aentails_all) +next + case (2 f) + have \mset_set idxs = (fst `# {# (s, f s) . s \ mset_set idxs #})\ + by (simp add: multiset_map_comp') + then show ?case + apply (rule_tac aexists_entailsR[of _ _ \{# (s, f s). s \ mset_set idxs #}\]) + apply (simp add: apure_precise_True asepconj_emp_unit) + by (metis (mono_tags, lifting) aentails_multi_map_core aentails_refl fst_conv snd_conv) qed lemma asepconj_multi_flatten: @@ -2187,12 +2563,9 @@ lemma asepconj_multi_flatten_constant_indexing_set: \\{# \ y x . (y, x) \ mset_set (B \ A) #}\ using assms by (clarsimp simp add: asepconj_multi_flatten set_product_sum) -lemma asepconj_multi_pure: - shows \\\{# \P x\ . x\ms #} = \\x \# ms. P x\\ -by (induction ms; auto simp add: asepconj_simp apure_def) - -lemma asepconj_multi_true_collapse [simp]: "\\ {# UNIV . x \ M #} = UNIV" - using asepconj_multi_pure[of \\x. True\] +lemma asepconj_multi_true_collapse [simp]: + "\\ {# UNIV . x \ M #} = (if M = {#} then emp else UNIV)" + using asepconj_multi_pure[of \\x. True\ M] by (force simp: asepconj_False_True) (*<*) diff --git a/Shallow_Separation_Logic/Assertion_Triple.thy b/Shallow_Separation_Logic/Assertion_Triple.thy index 1d683bdc..432a4f41 100644 --- a/Shallow_Separation_Logic/Assertion_Triple.thy +++ b/Shallow_Separation_Logic/Assertion_Triple.thy @@ -3,7 +3,7 @@ (*<*) theory Assertion_Triple - imports Shallow_Micro_Rust.Eval Assertion_Language Precision Locality "HOL-Library.Rewrite" + imports Shallow_Micro_Rust.Eval Assertion_Language Precision Locality begin context sepalg begin @@ -12,29 +12,79 @@ context sepalg begin subsubsection\Assertion triples\ text\The following relation expresses that two states \<^term>\\\ and \<^term>\\'\ are related by -'swapping out' a sub-state satisfying assertion \<^term>\\\ for a sub-state satisfying \<^term>\\\:\ +'swapping out' a sub-state satisfying assertion \<^term>\\\ for a sub-state satisfying \<^term>\\\. +The frame \<^term>\\\ ranges over all assertions, so the pre- and post-conditions account +exactly for the resource they describe:\ definition atriple :: \'a assert \ 'a \ 'a \ 'a assert \ bool\ ("(_) \/ '(_,_')/ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (_)" [50,50,50]50) where - \\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \\. ucincl \ \ \ \ \ \ \ \ \' \ \ \ \\ + \\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \\. \ \ \ \ \ \ \' \ \ \ \\ lemma atripleI: - assumes \\\. ucincl \ \ \ \ (\ \ \) \ \' \ (\ \ \)\ + assumes \\\. \ \ (\ \ \) \ \' \ (\ \ \)\ shows \\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \\ using assms by (auto simp add: atriple_def) lemma atripleE: assumes \\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \\ - and \(\\. ucincl \ \ \ \ (\ \ \) \ \' \ (\ \ \)) \ R\ + and \(\\. \ \ (\ \ \) \ \' \ (\ \ \)) \ R\ shows R using assms by (auto simp add: atriple_def) +text \Quantifying only over upwards-closed frames is equivalent to an exact triple whose +post-condition has the form \<^term>\\ \ \\:\ +lemma atriple_ucincl_frames_iff: + shows \(\\. ucincl \ \ \ \ \ \ \ \ \' \ \ \ \) \ + (\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \)\ +proof (rule iffI) + assume old: \\\. ucincl \ \ \ \ \ \ \ \ \' \ \ \ \\ + show \\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \\ + proof (rule atripleI) + fix \ + assume \\ \ \ \ \\ + have grow: \\ \ \ \ \ \ (\ \ \)\ + by (intro asepconj_mono asepconj_mono6 aentails_refl aentails_true) + from \\ \ \ \ \\ and grow have \\ \ \ \ (\ \ \)\ + by (simp add: aentails_def) + moreover have \ucincl (\ \ \)\ + by (intro ucincl_asepconjR ucincl_UNIV) + ultimately have \\' \ \ \ (\ \ \)\ + using old by blast + then show \\' \ (\ \ \) \ \\ + by (simp add: asepconj_AC) + qed +next + assume new: \\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \\ + show \\\. ucincl \ \ \ \ \ \ \ \ \' \ \ \ \\ + proof (intro allI impI) + fix \ + assume \ucincl \\ and \\ \ \ \ \\ + from new and \\ \ \ \ \\ have \\' \ (\ \ \) \ \\ + by (elim atripleE) + then show \\' \ \ \ \\ + using \ucincl \\ by (simp add: asepconj_assoc asepconj_ident) + qed +qed + +text \Instantiating the frame with the unit \<^term>\emp\ extracts the unframed state +transition:\ +lemma atripleE_emp_frame: + assumes \\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \\ + and \(\ \ \ \ \' \ \) \ R\ + shows \R\ +proof - + from assms(1) have \\ \ \ \ emp \ \' \ \ \ emp\ + by (elim atripleE) + from this and assms(2) show \R\ + by (simp add: asepconj_emp_unit) +qed + lemma atriple_refl: shows \\ \ (\, \) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \\ by (simp add: atriple_def) lemma atriple_refl': shows \\ \ (\, \) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \\ -by (simp add: atriple_def) (metis local.asepconj_assoc local.asepconj_ident local.asepconj_swap_top) + by (simp add: atriple_def asepconj_assoc asepconj_weaken2I) lemma atriple_pre_false: shows \{} \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \\ @@ -42,7 +92,7 @@ by (simp add: atriple_def local.asepconj_bot_zero) lemma atriple_post_true: shows \\ \ (\, \) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \\ -by (metis aentails_def atripleI local.aentails_cancel_l local.asepconj_ident) + by (meson aentails_def asat_connectives_characterisation(1) asepconj_mono4 atripleI) lemma atriple_consequence: assumes \\' \ \\ @@ -66,7 +116,7 @@ by (auto simp add: atriple_def asepconj_Inf_distrib' asepconj_simp) lemma atriple_frame_rule: assumes \\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \\ shows \\ \ \ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \\ -using assms by (simp add: atriple_def local.asepconj_assoc local.ucincl_asepconjR) +using assms by (simp add: atriple_def local.asepconj_assoc) lemma atriple_complement: assumes \\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \\ @@ -75,9 +125,7 @@ lemma atriple_complement: obtains \0' where \\0' \ \ \ \\ and \\0' \ \c\ and \\' = \0' + \c\ proof - let ?\ = \\\<^sub>s \c\ - have \ucincl ?\\ - by (simp add: uc_state_ucincl) - moreover have \\ \ ?\ \ \\ + have \\ \ ?\ \ \\ by (metis asat_def assms(2) assms(3) local.asepconjI local.asepconj_comm local.derived_order_refl local.is_splitting_def local.uc_state_def mem_Collect_eq) moreover from this have \\' \ ?\ \ \\ @@ -94,13 +142,20 @@ proof - local.sepalg_apart_plus_distrib local.sepalg_assoc local.sepalg_comm that) qed +text \The pure assertion \<^term>\apure (P)\ may absorb arbitrary resource, so hoisting it +leaves \<^term>\\ \ \\. Use \<^term>\\P\\ when the pure factor must own no +resource.\ lemma atriple_hoist_pure: - shows \(\ \ \P\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \) \ (P \ (\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \))\ - and \(\P\ \ \ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \) \ (P \ (\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \))\ (is ?g2) + shows \(\ \ apure (P) \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \) \ + (P \ (\ \ \ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \))\ + and \(apure (P) \ \ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \) \ + (P \ (\ \ \ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \))\ proof - - show \(\ \ \P\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \) \ (P \ (\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \))\ + show \(\ \ apure (P) \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \) \ + (P \ (\ \ \ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \))\ by (clarsimp simp add: atriple_def apure_def asepconj_simp) - from this show \(\P\ \ \ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \) \ (P \ (\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \))\ + from this show \(apure (P) \ \ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \) \ + (P \ (\ \ \ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \))\ by (simp add: asepconj_comm) qed @@ -121,18 +176,6 @@ lemma atriple_minimal: using assms by (clarsimp simp add: is_minimal_def asat_def atriple_def) (metis asat_def asepconjE asepconj_weakenI derived_order_def disjoint_sym reflE sepalg_apart_plus2 sepalg_comm) -text\The assertion triple is invariant under passage to upward closure:\ -lemma atriple_upwards_closure: - shows \((\ \ \) \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\ \ \)) \ (\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \)\ - and \((\ \ \) \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\ \ \)) \ (\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \)\ - and \((\ \ \) \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\ \ \)) \ (\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \)\ - and \((\ \ \) \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\ \ \)) \ (\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \)\ - and \(\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\ \ \)) \ (\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \)\ - and \(\ \ \ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \) \ (\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \)\ - and \(\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\ \ \)) \ (\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \)\ - and \(\ \ \ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \) \ (\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \)\ -by (simp add: atriple_def local.asepconj_assoc local.asepconj_ident local.ucincl_asepconjR)+ - (*<*) end @@ -144,38 +187,62 @@ lemma atriple_minimal': assumes \is_minimal \ \\ and \has_minimal_splittings \\ and \\' \ \\ + and \ucincl \\ + \\The residue of a minimal frame splitting is absorbed into the post-condition.\ and \\ \ \C\ and \\' \ \C\ and \\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \\ shows \\ \ (\ + \C, \' + \C) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \\ -proof - - have \precise (minimal_states \)\ and \\ = (minimal_states \) \ \\ - using assms(2) local.has_minimal_splittings_via_minimal_states by blast+ - { - fix \ - assume \ucincl \\ - and \\ + \C \ \ \ \\ - moreover from this obtain \0 \1 where \\0 \ \1\ and \\0 \ \\ \\1 \ \\ and \\ + \C = \0 + \1\ - by (metis local.asepconjE local.asepconj_comm) - moreover from this obtain \0' \0'' where \is_minimal_splitting \0 \0' \0'' \\ - by (meson assms(2) local.has_minimal_splittingsE) - moreover from this have \\0' \ minimal_states \\ - by (simp add: asat_def local.is_minimal_splitting_is_minimal local.minimal_states_def) - moreover from calculation have \\ + \C = \0' + (\0'' + \1)\ - using local.is_minimal_splitting_def local.is_splitting_def local.sepalg_assoc - local.sepalg_pairwise by force - moreover from calculation and \precise (minimal_states \)\ have \\ = \0'\ - by (metis asat_def assms(1) assms(4) local.derived_orderI is_minimal_splitting_def - is_splitting_def minimal_states_def preciseE local.sepalg_apart_assoc mem_Collect_eq) - moreover from calculation have \\0'' + \1 = \C\ - by (metis assms(4) local.disjoint_sym local.is_minimal_splitting_def local.is_splitting_def - local.sepalg_apart_assoc local.sepalg_cancel local.sepalg_comm) - ultimately have \(\' + \C) \ \ \ \\ - by (metis assms(3) assms(5) local.asat_weaken local.asepconjI local.disjoint_sym - local.is_minimal_splitting_def local.is_splitting_def local.sepalg_comm local.sepalg_pairwise2) - } - from this show ?thesis - by (simp add: local.asepconj_comm local.atriple_def) +proof (rule atripleI) + fix \ + assume H: \\ + \C \ \ \ \\ + from H obtain \0 \1 where split: \\ + \C = \0 + \1\ \\0 \ \1\ + \\0 \ \\ \\1 \ \\ + by (elim asepconjE) + from \\0 \ \\ and \has_minimal_splittings \\ obtain \m \r where + minsplit: \is_minimal_splitting \0 \m \r \\ + by (meson has_minimal_splittingsE) + from minsplit have mr: \\m \ \r\ and tau0_eq: \\0 = \m + \r\ + by (simp_all add: is_minimal_splitting_def is_splitting_def) + from mr and split(2) and tau0_eq have t1_m: \\1 \ \m\ and t1_r: \\1 \ \r\ + by (simp_all add: sepalg_pairwise2) + from t1_m and t1_r have m_t1: \\m \ \1\ and r_t1: \\r \ \1\ + by (simp_all add: disjoint_sym) + have tm_apart: \\m \ \r + \1\ + using mr m_t1 r_t1 by (simp add: sepalg_pairwise2) + have total: \\ + \C = \m + (\r + \1)\ + using split(1) tau0_eq sepalg_assoc[OF mr r_t1 m_t1] by simp + have precise_min: \precise (minimal_states \)\ + using \has_minimal_splittings \\ has_minimal_splittings_via_minimal_states by blast + have sigma_min: \\ \ minimal_states \\ + using \is_minimal \ \\ by (simp add: asat_def minimal_states_def) + have tm_min: \\m \ minimal_states \\ + using minsplit by (simp add: asat_def is_minimal_splitting_is_minimal minimal_states_def) + have sigma_below: \\ \ \ + \C\ + by (rule derived_orderI[where z=\\C\]) (simp add: \\ \ \C\) + have tm_below: \\m \ \ + \C\ + by (rule derived_orderI[where z=\\r + \1\]) (simp add: tm_apart total) + have sigma_eq: \\ = \m\ + using precise_min sigma_below tm_below sigma_min tm_min by (blast elim: preciseE) + have C_apart_sigma: \\C \ \\ + using \\ \ \C\ by (simp add: disjoint_sym) + have residual_apart_sigma: \\r + \1 \ \\ + using tm_apart sigma_eq by (simp add: disjoint_sym) + have sum_comm: \\C + \ = (\r + \1) + \\ + using total sigma_eq sepalg_comm[OF C_apart_sigma] sepalg_comm[OF residual_apart_sigma] + by simp + have residual_eq: \\C = \r + \1\ + using sepalg_cancel[OF sum_comm C_apart_sigma residual_apart_sigma] . + from \\' \ \C\ and residual_eq and r_t1 have out_r: \\' \ \r\ and out_t1: \\' \ \1\ + by (simp_all add: sepalg_pairwise2) + have out_psi: \\' + \r \ \\ + using asat_weaken[OF \\' \ \\ out_r \ucincl \\] . + have out_apart: \\' + \r \ \1\ + using sepalg_pairwise_apart[OF out_r r_t1 out_t1] . + have out_eq: \\' + \C = (\' + \r) + \1\ + using residual_eq sepalg_assoc[OF out_r r_t1 out_t1] by simp + show \\' + \C \ \ \ \\ + using asepconjI[OF out_eq out_apart out_psi split(4)] . qed (*<*) @@ -260,16 +327,18 @@ proof - moreover have \\ \ (\A0, \A0'') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \'\ and \\ \ (\B0, \B0' + C) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \'\ by (auto simp add: atriple_minimal calculation) moreover from calculation have \\ \ (\A0 + (\B0 + \Ac + \Bc), \A0'' + (\B0 + \Ac + \Bc)) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \'\ - using preciseA by (auto intro!: atriple_minimal' simp add: is_minimal_splitting_def - is_splitting_def sepalg_pairwise2) + using preciseA preciseA' + by (auto intro!: atriple_minimal' has_minimal_splittings_ucincl + simp add: is_minimal_splitting_def is_splitting_def sepalg_pairwise2) moreover have \\B0 \ (\A0'' + \Ac + \Bc)\ using calculation by (metis (no_types, opaque_lifting) disjoint_sym is_minimal_splitting_def is_splitting_def sepalg_pairwise2) moreover from calculation have \\B0' + C \ (\A0'' + \Ac + \Bc)\ by (metis (no_types, opaque_lifting) disjoint_sym sepalg_pairwise) moreover from calculation have \\ \ (\B0 + (\A0'' + \Ac + \Bc), \B0' + C + (\A0'' + \Ac + \Bc)) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \'\ - using preciseA by (auto simp add: preciseB is_minimal_splitting_def is_splitting_def - sepalg_pairwise sepalg_pairwise2 intro!: atriple_minimal') + using preciseB preciseB' + by (auto intro!: atriple_minimal' has_minimal_splittings_ucincl + simp add: is_minimal_splitting_def is_splitting_def sepalg_pairwise sepalg_pairwise2) moreover from calculation have \\B0' + C + (\A0'' + \Ac + \Bc) = \'\ by (metis (no_types, lifting) disjoint_sym sepalg_apart_plus sepalg_assoc sepalg_comm) moreover from calculation have \\A0'' + (\B0 + \Ac + \Bc) = \B0 + (\A0'' + \Ac + \Bc)\ (is \?a = ?b\) @@ -303,7 +372,7 @@ begin definition atriple_rel :: \'a assert \ ('a \ ('t \ 'a) \ bool) \ ('t \ 'a assert) \ bool\ ("(_) \/ _/ \\<^sub>R (_)" [50,50,50]50) where - \\ \ R \\<^sub>R \ \ is_local R \ \ (\\ \' v. R \ (v, \') \ \ \ \ \ \' \ \ v \ \)\ + \\ \ R \\<^sub>R \ \ is_local R \ \ (\\ \' v. R \ (v, \') \ \ \ \ \ \' \ \ v)\ definition atriple_rel_id :: \'a assert \ ('a \ 'a \ bool) \ bool\ ("_\_") where \\\P \ is_local0 P \ \ (\\ \'. \ \ \ \ P \ \' \ \' \ \)\ @@ -321,86 +390,33 @@ lemma atriple_local: shows \\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ v\ using assms by (clarsimp simp add: is_local_def atriple_def asat_def asepconj_def) (metis local.disjoint_sym) -lemma atriple_local': - assumes \is_local R \\ - and \\\ \' v. R \ (v, \') \ \ \ \ \ \' \ \ v \ \\ - and \R \ (v, \')\ - shows \\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ v\ -proof - - from assms have \\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\v. \ v \ \) v\ - by (intro atriple_local[where R=R]; simp) - from this show ?thesis - using atriple_upwards_closure(5) by blast -qed - -lemma atriple_rel_upwards_closure: - shows \(\ \ R \\<^sub>R \) \ (\ \ \ \ R \\<^sub>R (\v. \ v \ \))\ -proof - assume \\ \ R \\<^sub>R \\ - moreover { - fix \ v \' - assume \is_local R \\ - and \\\ \' v. R \ (v, \') \ \ \ \ \ \' \ \ v \ UNIV\ - and \R \ (v, \')\ - and \\ \ \ \ UNIV\ - from this calculation have \\' \ \ v \ UNIV\ - by (metis atriple_local' local.atripleE local.ucincl_UNIV) - } - ultimately show \\ \ \ \ R \\<^sub>R (\v. \ v \ \)\ - by (auto simp add: atriple_rel_def is_local_upwards_closure asepconj_simp) -next - assume \\ \ UNIV \ R \\<^sub>R (\v. \ v \ UNIV)\ - moreover { - fix \ \' v - assume \is_local R \\ - and \\\ \' v. R \ (v, \') \ \ \ \ \ UNIV \ \' \ \ v \ UNIV\ - and \R \ (v, \')\ - and \\ \ \\ - from this have \\' \ \ v \ UNIV\ - by (simp add: local.asepconj_weakenI) - } - ultimately show \\ \ R \\<^sub>R \\ - by (clarsimp simp add: atriple_rel_def is_local_upwards_closure asepconj_simp) -qed - +text \Hoisting an absorbing pure factor from an \<^term>\atriple_rel\ leaves +\<^term>\\ \ \\:\ lemma atriple_rel_hoist_pure: - shows \(\ \ \P\ \ R \\<^sub>R \) \ (P \ (\ \ R \\<^sub>R \))\ - and \(\P\ \ \ \ R \\<^sub>R \) \ (P \ (\ \ R \\<^sub>R \))\ + shows \(\ \ apure (P) \ R \\<^sub>R \) \ (P \ (\ \ \ \ R \\<^sub>R \))\ + and \(apure (P) \ \ \ R \\<^sub>R \) \ (P \ (\ \ \ \ R \\<^sub>R \))\ proof - { - assume \\ \ \P\ \ R \\<^sub>R \\ + assume \\ \ apure (P) \ R \\<^sub>R \\ and \P\ - from this have \\ \ R \\<^sub>R \\ + from this have \\ \ \ \ R \\<^sub>R \\ by (simp add: atriple_rel_def local.asepconj_False_True(2) local.asepconj_comm local.asepconj_weaken2I local.is_local_upwards_closure(2)) } moreover { assume \\ P\ - from this have \\ \ \P\ \ R \\<^sub>R \\ + from this have \\ \ apure (P) \ R \\<^sub>R \\ by (simp add: atriple_rel_def local.asat_apure_distrib'(1) local.is_local_hoist_pure) } moreover { - assume \\ \ R \\<^sub>R \\ - from this have \\ \ \P\ \ R \\<^sub>R \\ - by (clarsimp simp add: atriple_rel_def apure_def asepconj_simp) - (metis atriple_local' local.atripleE local.is_local_empty local.is_local_frame local.ucincl_UNIV) + assume \\ \ \ \ R \\<^sub>R \\ + from this have \\ \ apure (P) \ R \\<^sub>R \\ + by (clarsimp simp add: atriple_rel_def apure_def asepconj_simp) (metis local.is_local_empty) } - ultimately show \(\ \ \P\ \ R \\<^sub>R \) = (P \ \ \ R \\<^sub>R \)\ + ultimately show \(\ \ apure (P) \ R \\<^sub>R \) = (P \ \ \ \ \ R \\<^sub>R \)\ by auto - from this show \(\P\ \ \ \ R \\<^sub>R \) \ (P \ (\ \ R \\<^sub>R \))\ + from this show \(apure (P) \ \ \ R \\<^sub>R \) \ (P \ (\ \ \ \ R \\<^sub>R \))\ by (simp add: asepconj_comm) qed -lemma atriple_rel_upwards_closure': - shows \((\ \ \) \ R \\<^sub>R (\v. \ v \ \)) \ (\ \ R \\<^sub>R \)\ - and \((\ \ \) \ R \\<^sub>R (\v. \ \ \ v)) \ (\ \ R \\<^sub>R \)\ - and \((\ \ \) \ R \\<^sub>R (\v. \ \ \ v)) \ (\ \ R \\<^sub>R \)\ - and \((\ \ \) \ R \\<^sub>R (\v. \ v \ \)) \ (\ \ R \\<^sub>R \)\ - and \(\ \ R \\<^sub>R (\v. \ v \ \)) \ (\ \ R \\<^sub>R \)\ - and \(\ \ \ \ R \\<^sub>R \) \ (\ \ R \\<^sub>R \)\ - and \(\ \ R \\<^sub>R (\v. \ \ \ v)) \ (\ \ R \\<^sub>R \)\ - and \(\ \ \ \ R \\<^sub>R \) \ (\ \ R \\<^sub>R \)\ -by (rewrite at "\ \ _" atriple_rel_upwards_closure, rewrite at "_ \ \" - atriple_rel_upwards_closure, simp add: asepconj_simp asepconj_comm asepconj_UNIV_collapse_top)+ - lemma atriple_rel_bind: fixes \ :: \'a assert\ and \ :: \'v \ 'a assert\ @@ -410,12 +426,10 @@ lemma atriple_rel_bind: and B: \\v. (\ v \ S v \\<^sub>R \)\ shows \\ \ R \ S \\<^sub>R \\ proof - - from assms have \\v. (\ v \ \ \ S v \\<^sub>R \)\ - by (metis atriple_rel_upwards_closure local.asepconj_UNIV_idempotent local.asepconj_assoc) - moreover { - assume \

: \(\v. is_local (S v) (\ v \ UNIV) \ (\\ \' va. S v \ (va, \') \ \ \ \ v \ UNIV \ \' \ \ va \ UNIV))\ + { + assume \
: \(\v. is_local (S v) (\ v) \ (\\ \' va. S v \ (va, \') \ \ \ \ v \ \' \ \ va))\ and \is_local R \\ - and \\\ \' v. R \ (v, \') \ \ \ \ \ \' \ \ v \ UNIV\ + and \\\ \' v. R \ (v, \') \ \ \ \ \ \' \ \ v\ moreover { fix \_0 \_1 \_0' v assume \\_0 \ \_1\ @@ -442,13 +456,13 @@ proof - by (intro is_localI) } moreover { fix \ \' v - assume \\v. is_local (S v) (\ v) \ (\\ \' va. S v \ (va, \') \ \ \ \ v \ \' \ \ va \ UNIV)\ + assume \\v. is_local (S v) (\ v) \ (\\ \' va. S v \ (va, \') \ \ \ \ v \ \' \ \ va)\ and \is_local R \\ - and \\\ \' v. R \ (v, \') \ \ \ \ \ \' \ \ v \ UNIV\ + and \\\ \' v. R \ (v, \') \ \ \ \ \ \' \ \ v\ and \(R \ S) \ (v, \')\ and \\ \ \\ - from this calculation have \\' \ \ v \ UNIV\ - by (metis asat_def atriple_rel_def rel_compose_def) + from this calculation have \\' \ \ v\ + by (metis rel_compose_def) } ultimately show ?thesis using assms by (auto simp add: atriple_rel_def asat_def) diff --git a/Shallow_Separation_Logic/Function_Contract.thy b/Shallow_Separation_Logic/Function_Contract.thy index 95cee794..3f2e3a3c 100644 --- a/Shallow_Separation_Logic/Function_Contract.thy +++ b/Shallow_Separation_Logic/Function_Contract.thy @@ -28,9 +28,6 @@ definition satisfies_function_contract :: \('a, 'abort, 'i, 'o) striple_co ('a, 'r, 'abort, 'i prompt, 'o prompt_output) function_body \ ('a, 'r, 'abort) function_contract \ bool\ (\(_)/ ; (_) \\<^sub>F (_)\ [50,50,50]50) where \\ ; f \\<^sub>F \ \ - ucincl (function_contract_pre \) \ - (\r. ucincl (function_contract_post \ r)) \ - (\r. ucincl (function_contract_abort \ r)) \ \ ; function_contract_pre \ \ function_body f \ function_contract_post \ @@ -38,10 +35,7 @@ definition satisfies_function_contract :: \('a, 'abort, 'i, 'o) striple_co \ function_contract_abort \\ lemma satisfies_function_contractI: - assumes \ucincl (function_contract_pre \)\ - and \\r. ucincl (function_contract_post \ r)\ - and \\r. ucincl (function_contract_abort \ r)\ - and \\ ; function_contract_pre \ \ function_body f + assumes \\ ; function_contract_pre \ \ function_body f \ function_contract_post \ \ function_contract_post \ \ function_contract_abort \\ shows \\ ; f \\<^sub>F \\ using assms by (simp add: satisfies_function_contract_def) @@ -49,20 +43,14 @@ lemma satisfies_function_contractI: lemma satisfies_function_contractE: assumes \\ ; f \\<^sub>F \\ and \(\\. \ ; function_contract_pre \ \ call f - \ function_contract_post \ \ \ \ function_contract_abort \) \ - ucincl (function_contract_pre \) \ - (\r. ucincl (function_contract_post \ r)) \ - (\r. ucincl (function_contract_abort \ r)) \ R\ + \ function_contract_post \ \ \ \ function_contract_abort \) \ R\ shows \R\ using assms by (cases f) (simp add: satisfies_function_contract_def sstriple_callI) lemma satisfies_function_contractE': assumes \\ ; f \\<^sub>F \\ and \(\ ; function_contract_pre \ \ function_body f - \ function_contract_post \ \ function_contract_post \ \ function_contract_abort \) \ - ucincl (function_contract_pre \) \ - (\r. ucincl (function_contract_post \ r)) \ - (\r. ucincl (function_contract_abort \ r)) \ R\ + \ function_contract_post \ \ function_contract_post \ \ function_contract_abort \) \ R\ shows \R\ using assms by (cases f) (simp add: satisfies_function_contract_def sstriple_callI) @@ -93,7 +81,7 @@ text\This contract requires that a function behaves precisely like the fir function), and does so without requiring any state.\ definition lift_pure_to_contract :: \'b \ ('s::sepalg, 'b, 'c) function_contract\ where \lift_pure_to_contract pure \ - let pre = \ in + let pre = emp in let post = \ ret. \ret = pure\ in make_function_contract pre post\ diff --git a/Shallow_Separation_Logic/Locality.thy b/Shallow_Separation_Logic/Locality.thy index 48cb889c..e8793916 100644 --- a/Shallow_Separation_Logic/Locality.thy +++ b/Shallow_Separation_Logic/Locality.thy @@ -168,7 +168,7 @@ proof - qed lemma is_local_hoist_pure: - shows \is_local R (\ \ \P\) \ P \ is_local R \\ + shows \is_local R (\ \ apure (P)) \ P \ is_local R \\ by (simp add: apure_def is_local_empty is_local_upwards_closure(1) local.asepconj_bot_zero2) lemma is_local_False: diff --git a/Shallow_Separation_Logic/Precision.thy b/Shallow_Separation_Logic/Precision.thy index 3282164a..be4ebcfe 100644 --- a/Shallow_Separation_Logic/Precision.thy +++ b/Shallow_Separation_Logic/Precision.thy @@ -58,9 +58,8 @@ theorem precise_alt: shows \precise \ \ (\\1 \2. \1 \ \ \ \2 \ \ \ \1 \ \2 \ (\\<^sub>s \1) \ (\\<^sub>s \2) = \)\ by (auto simp add: precise_def asat_def derived_order_def uc_state_def) -text \It is important to note that while we are mostly working with upwards closed assertions, -precise assertions in the above sense are rarely upwards closed. If they are, they can only consist -of \<^verbatim>\\\-maximal elements:\ +text \Precision and upwards closure pull in opposite directions: a precise assertion in the above +sense is rarely upwards closed, and if it is, it can only consist of \<^verbatim>\\\-maximal elements:\ lemma precise_ucincl: assumes \ucincl \\ @@ -89,6 +88,17 @@ lemma empty_set_precise: shows \precise {}\ by (auto simp add: precise_def) +text \The empty assertion has a unique satisfying substate.\ +corollary emp_precise: + shows \precise emp\ +by (simp add: emp_def singleton_set_precise) + +text \Semantic precision means uniqueness of satisfying substates and is +independent of the zero-ownership convention in \<^term>\apure_precise\.\ +corollary apure_precise_is_precise: + shows \precise \P\\ +by (simp add: precise_def asat_apure_precise_characterisation) + lemma conjunction_preserves_precise: assumes \precise \\ and \precise \\ @@ -553,4 +563,4 @@ qed end end -(*>*) \ No newline at end of file +(*>*) diff --git a/Shallow_Separation_Logic/Share_Map.thy b/Shallow_Separation_Logic/Share_Map.thy index aee6da01..95f57e50 100644 --- a/Shallow_Separation_Logic/Share_Map.thy +++ b/Shallow_Separation_Logic/Share_Map.thy @@ -478,7 +478,7 @@ lemma rbt_share_map_decompose_generic: proof (induct rule: rbt_share_map_induct) case 1 then show ?case - by (clarsimp simp add: asat_def asepconj_simp) + by (clarsimp simp add: asat_def asepconj_simp emp_def) next case (2 k sh v m) then have ND': \rbt_share_map_\ m k = No_Value\ @@ -505,7 +505,7 @@ lemma rbt_share_map_decompose_by_domain: proof (induct rule: rbt_share_map_induct) case 1 then show ?case - by (auto simp add: asat_def asepconj_simp) + by (auto simp add: asat_def asepconj_simp emp_def) next case (2 k sh v m) then have ND': \rbt_share_map_\ m k = No_Value\ diff --git a/Shallow_Separation_Logic/Triple.thy b/Shallow_Separation_Logic/Triple.thy index 2067baa9..e1b865ef 100644 --- a/Shallow_Separation_Logic/Triple.thy +++ b/Shallow_Separation_Logic/Triple.thy @@ -52,14 +52,6 @@ lemma sstripleI: shows \\ ; \ \ e \ \ \ \ \ \\ using assms sstriple_def by blast -lemma sstriple_upwards_closure: - shows \(\ ; \ \ e \ \ \ \ \ \) \ (\ ; \ \ \ \ e \ \ \ \ \ \)\ - and \(\ ; \ \ e \ \ \ \ \ \) \ (\ ; \ \ e \ (\r. \ r \ \) \ \ \ \)\ - and \(\ ; \ \ e \ \ \ \ \ \) \ (\ ; \ \ e \ \ \ (\r. \ r \ \) \ \)\ - and \(\ ; \ \ e \ \ \ \ \ \) \ (\ ; \ \ e \ \ \ \ \ (\a. \ a \ \))\ - and \(\ ; \ \ e \ \ \ \ \ \) \ (\ ; \ \ e \ (\r. \ r \ \) \ (\r. \ r \ \) \ (\a. \ a \ \))\ - by (auto simp add: sstriple_def atriple_rel_upwards_closure' asepconj_simp) - lemma sstriple_striple: fixes \ :: \('a, 'abort, 'i, 'o) striple_context\ and \ :: \'a assert\ @@ -75,7 +67,7 @@ lemma sstriple_striple: proof - { assume SS: \\ ; \ \ e \ \ \ \ \ \\ then have \\ ; \ \ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \\ - by (intro striple_localI'; auto simp add: sstriple_def atriple_rel_def + by (intro striple_localI; auto simp add: sstriple_def atriple_rel_def eval_value_def eval_return_def eval_abort_def asepconj_weakenI) moreover from SS have \is_local (eval_value (yh \) e) \\ and \is_local (eval_return (yh \) e) \\ @@ -91,9 +83,11 @@ proof - and \is_local (eval_return (yh \) e) \\ and \is_local (eval_abort (yh \) e) \\ then have \\ ; \ \ e \ \ \ \ \ \\ - by (intro sstripleI; clarsimp simp add: atriple_rel_def eval_value_def eval_return_def - eval_abort_def striple_def atriple_def urust_eval_action_via_predicate ucincl_UNIV - asepconj_weakenI) + \\Instantiating each weak triple's frame with \<^term>\emp\ gives the exact + relational post-condition.\ + by (intro sstripleI; + clarsimp simp add: atriple_rel_def eval_value_def eval_return_def eval_abort_def) + (blast elim: stripleE_value stripleE_return stripleE_abort atripleE_emp_frame)+ } ultimately show ?thesis by auto @@ -131,9 +125,6 @@ lemma striple_from_sstripleI: lemma sstriple_satisfiable: assumes \striple_context_no_yield ; \ \ e \ \ \ \ \ \\ and \is_sat \\ - and \\v. ucincl (\ v)\ - and \\r. ucincl (\ r)\ - and \\a. ucincl (\ a)\ shows \(\v. is_sat (\ v)) \ (\r. is_sat (\ r)) \ (\a. is_sat (\ a))\ using assms striple_satisfiable striple_from_sstripleI by blast @@ -256,77 +247,77 @@ lemma sstriple_skipI: text\Executing a literal does not modify the state in anyway way, but does return the literal value. It also always succeeds:\ lemma sstriple_literalI: - shows \\ ; \ \ \v \ (\rv. \rv = v\) \ \ \ \\ + shows \\ ; \ \ \v \ (\rv. apure (rv = v)) \ \ \ \\ by (auto intro: sstriple_from_stripleI striple_literalI simp add: urust_eval_predicate_literal is_local_def eval_value_def eval_return_def eval_abort_def) lemma sstriple_literal: - shows \(\ ; \ \ \v \ \ \ \ \ \) \ (\ \ \ v \ \)\ + shows \(\ ; \ \ \v \ \ \ \ \ \) \ (\ \ \ v)\ proof (intro iffI) - show \\ ; \ \ \v \ \ \ \ \ \ \ \ \ \ v \ UNIV\ + show \\ ; \ \ \v \ \ \ \ \ \ \ \ \ \ v\ by (simp add: local.striple_literal sstriple_striple') - show \\ \ \ v \ UNIV \ \ ; \ \ \v \ \ \ \ \ \\ + show \\ \ \ v \ \ ; \ \ \v \ \ \ \ \ \\ by (meson aentails_true is_local_weaken striple_literal sstriple_literalI sstriple_striple) qed lemma sstriple_assert_val: shows \(\ ; \ \ assert_val v \ \ \ \ \ \) \ - ((v \ \ \ \ \ \ ()) \ (\v \ \ \ \ \ \ AssertionFailed))\ + ((v \ \ \ \ ()) \ (\v \ \ \ \ AssertionFailed))\ by (auto simp add: sstriple_striple striple_assert_val eval_value_def eval_abort_def eval_return_def urust_eval_predicate_simps is_local_def) lemma sstriple_assert: shows \(\ ; \ \ \assert!(v)\ \ \ \ \ \ \) \ - (v \ \ \ \ \ \ ()) \ (\v \ \ \ \ \ \ AssertionFailed)\ + (v \ \ \ \ ()) \ (\v \ \ \ \ AssertionFailed)\ by (simp add: assert_def micro_rust_simps sstriple_assert_val) \\NOTE: This lemma is not used at present, but seems worth keeping.\ lemma sstriple_assert_eq: shows \(\ ; \ \ \assert_eq!(v,w)\ \ \ \ \ \ \) \ - (v=w \ \ \ \ \ \ ()) \ (v \ w \ \ \ \ \ \ AssertionFailed)\ + (v=w \ \ \ \ ()) \ (v \ w \ \ \ \ AssertionFailed)\ by (simp add: assert_eq_def assert_eq_val_def sstriple_assert_val micro_rust_simps) text\The \<^verbatim>\return_func\ command always succeeds and returns the given value:\ \\NOTE: This lemma is not used at present, but seems worth keeping.\ lemma sstriple_return_valI: - shows \\ ; \ \ return_val v \ \ \ (\rv. \rv = v\) \ \\ + shows \\ ; \ \ return_val v \ \ \ (\rv. apure (rv = v)) \ \\ by (auto intro!: sstriple_from_stripleI striple_return_valI simp add: urust_eval_predicate_return is_local_def eval_value_def eval_return_def eval_abort_def) lemma sstriple_return_val: - shows \(\ ; \ \ return_val v \ \ \ \ \ \) \ (\ \ \ v \ \)\ + shows \(\ ; \ \ return_val v \ \ \ \ \ \) \ (\ \ \ v)\ proof - show \\ ; \ \ return_val v \ \ \ \ \ \ \ \ \ \ v \ UNIV\ + show \\ ; \ \ return_val v \ \ \ \ \ \ \ \ \ \ v\ by (simp add: striple_return_val sstriple_striple) - show \\ \ \ v \ UNIV \ \ ; \ \ return_val v \ \ \ \ \ \\ + show \\ \ \ v \ \ ; \ \ return_val v \ \ \ \ \ \\ by (meson aentails_true is_local_weaken striple_return_val sstriple_return_valI sstriple_striple) qed text\The \<^verbatim>\return_func\ command always succeeds and returns the given value:\ \\NOTE: This lemma is not used at present, but seems worth keeping.\ lemma sstriple_returnI: - shows \\ ; \ \ return_func (\v) \ \ \ (\rv. \rv = v\) \ \\ + shows \\ ; \ \ return_func (\v) \ \ \ (\rv. apure (rv = v)) \ \\ by (simp add: bind_literal_unit return_func_def sstriple_return_valI) lemma sstriple_return: - shows \(\ ; \ \ return_func (\v) \ \ \ \ \ \) \ (\ \ \ v \ \)\ + shows \(\ ; \ \ return_func (\v) \ \ \ \ \ \) \ (\ \ \ v)\ by (simp add: bind_literal_unit return_func_def sstriple_return_val) corollary sstriple_noneI: - shows \\ ; \ \ `None \ (\rv. \rv = None\) \ \ \ \\ + shows \\ ; \ \ `None \ (\rv. apure (rv = None)) \ \ \ \\ unfolding none_def by (rule sstriple_literalI) corollary sstriple_trueI: - shows \\ ; \ \ `True \ (\rv. \rv = True\) \ \ \ \\ + shows \\ ; \ \ `True \ (\rv. apure (rv = True)) \ \ \ \\ unfolding true_def by (rule sstriple_literalI) corollary sstriple_falseI: - shows \\ ; \ \ `False \ (\rv. \rv = False\) \ \ \ \\ + shows \\ ; \ \ `False \ (\rv. apure (rv = False)) \ \ \ \\ unfolding false_def by (rule sstriple_literalI) corollary sstriple_someI: notes asepconj_simp [simp] - shows \\ ; \ \ `Some (\x) \ (\rv. \rv = Some x\) \ \ \ \\ + shows \\ ; \ \ `Some (\x) \ (\rv. apure (rv = Some x)) \ \ \ \\ apply (intro sstriple_from_stripleI striple_someI) apply (auto simp add: return_func_def urust_eval_predicate_literal urust_eval_predicate_return micro_rust_simps some_def is_local_def eval_value_def eval_return_def eval_abort_def) @@ -334,34 +325,30 @@ corollary sstriple_someI: text\Abort and panic terminate execution of the program:\ lemma sstriple_abort: - shows \(\ ; \ \ abort m \ \ \ \ \ \) \ (\ \ \ m \ \)\ + shows \(\ ; \ \ abort m \ \ \ \ \ \) \ (\ \ \ m)\ by (fastforce simp add: sstriple_striple striple_abort is_local_def eval_value_def eval_return_def eval_abort_def urust_eval_predicate_simps) text\Panic terminates execution of the program:\ \\NOTE: This lemma is not used at present, but seems worth keeping.\ lemma sstriple_panic: - shows \(\ ; \ \ panic m \ \ \ \ \ \) \ (\ \ \ (Panic m) \ \)\ + shows \(\ ; \ \ panic m \ \ \ \ \ \) \ (\ \ \ (Panic m))\ by (simp add: sstriple_abort) text\Pause / Breakpoint\ lemma sstriple_pause: - assumes \\r. ucincl (\ r)\ - shows \(\ ; \ \ \ \\\\\ \ \ \ \ \ \ \)\ - using assms + shows \(\ ; \ \ \ \\\\\ \ \ \ \ \ \ \)\ by (auto intro!: sstriple_from_stripleI striple_pause simp add: is_local_def eval_return_def eval_value_def eval_abort_def urust_eval_predicate_simps is_valid_striple_context_def) lemma sstriple_pause': - assumes \\r. ucincl (\ r)\ shows \(\ ; \ \ \ \\\\\ \ \ \ \ \ \ \) \ (\ \ \ ())\ proof show \\ ; \ \ pause \ \ \ \ \ \ \ \ \ \ ()\ - using assms by (simp add: striple_pause' sstriple_striple') + by (simp add: striple_pause' sstriple_striple') show \\ \ \ () \ \ ; \ \ pause \ \ \ \ \ \\ - using assms by (auto simp: sstriple_striple striple_pause' is_local_def eval_return_def eval_value_def eval_abort_def urust_eval_predicate_simps) qed @@ -374,20 +361,18 @@ lemma sstriple_log: is_valid_striple_context_def eval_abort_def) lemma sstriple_log': - assumes \\r. ucincl (\ r)\ shows \(\ ; \ \ \ \\\ \p\ \l\ \ \ \ \ \ \ \) \ (\ \ \ ())\ proof show \\ ; \ \ log p l \ \ \ \ \ \ \ \ \ \ ()\ - using assms by (simp add: local.striple_log' sstriple_striple') + by (simp add: local.striple_log' sstriple_striple') show \\ \ \ () \ \ ; \ \ log p l \ \ \ \ \ \\ - using assms by (meson aentails_true is_local_weaken striple_log' sstriple_log sstriple_striple) + by (meson aentails_true is_local_weaken striple_log' sstriple_log sstriple_striple) qed text\Fatal errors\ lemma sstriple_fatal: assumes \is_aborting_striple_context \\ - and \\r. ucincl (\ r)\ shows \(\ ; \ \ \ fatal!(msg) \ \ \ \ \ \ \)\ using assms by (auto intro!: sstriple_from_stripleI @@ -400,8 +385,8 @@ lemma sstriple_yield: shows \(\; \ \ yield \ \ \ \ \ \ \) \ ( is_local (\\ (v, \'). YieldContinue (v, \') \ yh \ \ \) \ \ is_local (\\ (a, \'). YieldAbort a \' \ yh \ \ \) \ \ - (\\ \' v. YieldContinue (v, \') \ yh \ \ \ \ \ \ \ \ \' \ \ v \ UNIV) \ - (\\ \' a. YieldAbort a \' \ yh \ \ \ \ \ \ \ \ \' \ \ a \ UNIV))\ + (\\ \' v. YieldContinue (v, \') \ yh \ \ \ \ \ \ \ \ \' \ \ v) \ + (\\ \' a. YieldAbort a \' \ yh \ \ \ \ \ \ \ \ \' \ \ a))\ by (auto simp add: sstriple_def eval_abort_def eval_value_def eval_return_def is_local_False urust_eval_predicate_simps urust_eval_action_via_predicate striple_yield atriple_rel_def) @@ -423,20 +408,22 @@ using assms by (auto simp: sstriple_def atriple_rel_def urust_eval_predicate_cal urust_eval_predicate_call_rel is_local_disj) (subst is_local_def; clarsimp) lemma sstriple_call_funliteral: - shows \(\ ; \ \ \ \f1\\<^sub>1 (v0) \ \ \ \ \ \ \) \ (\ \ \ (f1 v0) \ \)\ - and \(\ ; \ \ \ \f2\\<^sub>2 (v0, v1) \ \ \ \ \ \ \) \ (\ \ \ (f2 v0 v1) \ \)\ - and \(\ ; \ \ \ \f3\\<^sub>3 (v0, v1, v2) \ \ \ \ \ \ \) \ (\ \ \ (f3 v0 v1 v2) \ \)\ - and \(\ ; \ \ \ \f4\\<^sub>4 (v0, v1, v2, v3) \ \ \ \ \ \ \) \ (\ \ \ (f4 v0 v1 v2 v3) \ \)\ - and \(\ ; \ \ \ \f5\\<^sub>5 (v0, v1, v2, v3, v4) \ \ \ \ \ \ \) \ (\ \ \ (f5 v0 v1 v2 v3 v4) \ \)\ - and \(\ ; \ \ \ \f6\\<^sub>6 (v0, v1, v2, v3, v4, v5) \ \ \ \ \ \ \) \ (\ \ \ (f6 v0 v1 v2 v3 v4 v5) \ \)\ - and \(\ ; \ \ \ \f7\\<^sub>7 (v0, v1, v2, v3, v4, v5, v6) \ \ \ \ \ \ \) \ (\ \ \ (f7 v0 v1 v2 v3 v4 v5 v6) \ \)\ - and \(\ ; \ \ \ \f8\\<^sub>8 (v0, v1, v2, v3, v4, v5, v6, v7) \ \ \ \ \ \ \) \ (\ \ \ (f8 v0 v1 v2 v3 v4 v5 v6 v7) \ \)\ + shows \(\ ; \ \ \ \f1\\<^sub>1 (v0) \ \ \ \ \ \ \) \ (\ \ \ (f1 v0))\ + and \(\ ; \ \ \ \f2\\<^sub>2 (v0, v1) \ \ \ \ \ \ \) \ (\ \ \ (f2 v0 v1))\ + and \(\ ; \ \ \ \f3\\<^sub>3 (v0, v1, v2) \ \ \ \ \ \ \) \ (\ \ \ (f3 v0 v1 v2))\ + and \(\ ; \ \ \ \f4\\<^sub>4 (v0, v1, v2, v3) \ \ \ \ \ \ \) \ (\ \ \ (f4 v0 v1 v2 v3))\ + and \(\ ; \ \ \ \f5\\<^sub>5 (v0, v1, v2, v3, v4) \ \ \ \ \ \ \) \ (\ \ \ (f5 v0 v1 v2 v3 v4))\ + and \(\ ; \ \ \ \f6\\<^sub>6 (v0, v1, v2, v3, v4, v5) \ \ \ \ \ \ \) \ (\ \ \ (f6 v0 v1 v2 v3 v4 v5))\ + and \(\ ; \ \ \ \f7\\<^sub>7 (v0, v1, v2, v3, v4, v5, v6) \ \ \ \ \ \ \) \ (\ \ \ (f7 v0 v1 v2 v3 v4 v5 v6))\ + and \(\ ; \ \ \ \f8\\<^sub>8 (v0, v1, v2, v3, v4, v5, v6, v7) \ \ \ \ \ \ \) \ (\ \ \ (f8 v0 v1 v2 v3 v4 v5 v6 v7))\ by (fastforce simp: sstriple_striple striple_call_funliteral micro_rust_simps striple_literal eval_value_def eval_return_def eval_abort_def is_local_def urust_eval_predicate_simps)+ +\\Upwards closure lets \<^term>\get\ observe \<^term>\has f v\ in the full +machine state.\ lemma sstriple_getI: assumes \ucincl (has f v)\ - shows \\; has f v \ get f \ (\x. \x = v\ \ has f v) \ \ \ \\ + shows \\; has f v \ get f \ (\x. apure (x = v) \ has f v) \ \ \ \\ proof - from \ucincl (has f v)\ have \\x y. x \ y \ x \ has f v \ (x + y) \ has f v\ by (simp add: local.asat_weaken) @@ -504,25 +491,25 @@ by (auto intro!: sstriple_from_stripleI striple_word_shift_rightI simp add: eval lemma sstriple_bitwise_orI: fixes x y :: \'l::{len} word\ - shows \\ ; \ \ \ x | y \ \ (\r. \r = x OR y\) \ \ \ \\ + shows \\ ; emp \ \ x | y \ \ (\r. \r = x OR y\) \ \ \ \\ by (auto intro!: sstriple_from_stripleI striple_bitwise_orI simp add: eval_value_def eval_return_def urust_eval_predicate_simps is_local_def eval_abort_def) lemma sstriple_bitwise_andI: fixes x y :: \'l::{len} word\ - shows \\ ; \ \ \ x & y \ \ (\r. \r = x AND y\) \ \ \ \\ + shows \\ ; emp \ \ x & y \ \ (\r. \r = x AND y\) \ \ \ \\ by (auto intro!: sstriple_from_stripleI striple_bitwise_andI simp add: eval_value_def eval_return_def urust_eval_predicate_simps is_local_def eval_abort_def) lemma sstriple_bitwise_xorI: fixes x y :: \'l::{len} word\ - shows \\ ; \ \ \ x ^ y \ \ (\r. \r = x XOR y\) \ \ \ \\ + shows \\ ; emp \ \ x ^ y \ \ (\r. \r = x XOR y\) \ \ \ \\ by (auto intro!: sstriple_from_stripleI striple_bitwise_xorI simp add: eval_value_def eval_return_def urust_eval_predicate_simps is_local_def eval_abort_def) lemma sstriple_bitwise_notI: fixes x :: \'l::{len} word\ - shows \\ ; \ \ \ !x \ \ (\r. \r = NOT x\) \ \ \ \\ + shows \\ ; emp \ \ !x \ \ (\r. \r = NOT x\) \ \ \ \\ by (auto intro!: sstriple_from_stripleI striple_bitwise_notI simp add: eval_value_def eval_return_def urust_eval_predicate_simps is_local_def eval_abort_def) @@ -552,8 +539,7 @@ qed lemma sstriple_raw_for_loop_framed: notes aentails_intro [intro] fixes INV :: \'t list \ 't list \ 'a assert\ - assumes \\p t. ucincl (INV p t)\ - and \\past cur todo. \ ; INV past (cur # todo) \ f cur \ (\_. INV (past @ [cur]) todo) \ \ \ \\ + assumes \\past cur todo. \ ; INV past (cur # todo) \ f cur \ (\_. INV (past @ [cur]) todo) \ \ \ \\ shows \\ ; INV [] xs \ ((INV xs [] \ \ ()) \ (\r. \ r \ \ r) \ (\r. \ r \ \ r)) \ raw_for_loop xs f \ \ \ \ \ \\ proof - let ?pc = \(INV xs [] \ \ ()) \ (\r. \ r \ \ r) \ (\r. \ r \ \ r)\ @@ -626,8 +612,7 @@ proof - using assms by auto moreover have \\ ; INV xs i \ ?pc \ f (xs ! i) \ (\_. INV xs (i+1) \ ?pc) \ (\r. \ r \ ?pc) \ (\a. \ a \ ?pc)\ - using calculation assms by (intro sstriple_frame_rule) - (auto intro!: ucincl_Int ucincl_awand ucincl_inter) + using calculation assms by (auto intro!: sstriple_frame_rule) moreover have \\r. \ r \ ?pc \ \ r\ proof - have \\r. \ r \ (\r. \ r \ \ r) \ \ r\ @@ -709,9 +694,7 @@ lemma sstriple_bounded_while_framed: notes aentails_intro [intro] fixes INV :: \nat \ 'a assert\ and INV' :: \nat \ 'a assert\ - assumes ucincl_INV: \\k. ucincl (INV k)\ - and ucincl_INV': \\k. ucincl (INV' k)\ - and cond_step: \\k. k < n \ + assumes cond_step: \\k. k < n \ \ ; INV (Suc k) \ cond \ (\c. if c then INV' k else INV 0) \ \ \ \\ and body_step: \\k. k < n \ @@ -738,7 +721,7 @@ proof - have \\ ; INV (Suc k) \ ?pc \ cond \ (\c. (if c then INV' k else INV 0) \ ?pc) \ (\r. \ r \ ?pc) \ (\a. \ a \ ?pc)\ - using cond_step[OF kn] ucincl_INV by (intro sstriple_frame_rule; clarsimp) + using cond_step[OF kn] by (intro sstriple_frame_rule; clarsimp) moreover have \\c. (if c then INV' k else INV 0) \ ?pc \ (if c then INV' k \ ?pc else \ ())\ using inv0_psi by (auto simp add: aentails_refl) @@ -753,7 +736,7 @@ proof - assume kn: \k < n\ have \\ ; INV' k \ ?pc \ body \ (\_. INV k \ ?pc) \ (\r. \ r \ ?pc) \ (\a. \ a \ ?pc)\ - using body_step[OF kn] ucincl_INV' by (intro sstriple_frame_rule; clarsimp) + using body_step[OF kn] by (intro sstriple_frame_rule; clarsimp) from this have \\ ; INV' k \ ?pc \ body \ (\_. INV k \ ?pc) \ \ \ \\ using tau_rho theta_chi @@ -771,14 +754,17 @@ lemma sstriple_gather_spec': fixes INV :: \nat \ 'v list \ 'a assert\ and thunks :: \('a, 'v, 'r, 'abort, 'i prompt, 'o prompt_output) expression list\ assumes \\i ls. i < length thunks \ length ls = i \ (\ ; INV i ls \ thunks ! i \ (\v. INV (i+1) (ls @ [v])) \ \ \ \)\ - shows \\ ; INV 0 [] \ gather' thunks acc \ (\rs. \rs'. \rs = acc @ rs'\ \ INV (length thunks) rs') \ \ \ \\ + shows \\ ; INV 0 [] \ gather' thunks acc + \ (\rs. \rs'. \rs = acc @ rs'\ \ INV (length thunks) rs') \ \ \ \\ using assms proof (induction thunks arbitrary: INV acc) case Nil - then show ?case - by (auto simp: gather'_nil apure_def urust_eval_predicate_literal - eval_value_def eval_abort_def eval_return_def sstriple_def atriple_rel_def is_local_def - local.asepconj_comm local.asepconj_weaken2I) + have \INV 0 [] \ \acc = acc @ []\ \ INV 0 []\ + by (simp add: asepconj_simp aentails_refl) + from this have \INV 0 [] \ (\rs'. \acc = acc @ rs'\ \ INV 0 rs')\ + by (rule aexists_entailsR) + from this show ?case + by (simp add: gather'_nil sstriple_literal) next case (Cons t thunks) then have first: \\ ; INV 0 [] \ t \ (\v. INV 1 [v]) \ \ \ \\ @@ -808,18 +794,19 @@ lemma sstriple_gather_spec: notes aentails_intro [intro] fixes INV :: \nat \ 'v list \ 'a assert\ and thunks :: \('a, 'v, 'r, 'abort, 'i prompt, 'o prompt_output) expression list\ - assumes \\i ls. ucincl (INV i ls)\ - and \\i ls. i < length thunks \ length ls = i \ + assumes \\i ls. i < length thunks \ length ls = i \ \ ; INV i ls \ thunks ! i \ (\v. INV (i+1) (ls @ [v])) \ \ \ \\ shows \\ ; INV 0 [] \ gather thunks \ (\rs. INV (length thunks) rs) \ \ \ \\ proof - from assms and gather_spec'[where INV=INV and thunks=thunks] have - \\ ; INV 0 [] \ gather thunks \ (\rs. \rs'. \rs = [] @ rs'\ \ INV (length thunks) rs') \ \ \ \\ + \\ ; INV 0 [] \ gather thunks + \ (\rs. \rs'. \rs = [] @ rs'\ \ INV (length thunks) rs') \ \ \ \\ unfolding gather_def using sstriple_gather_spec' by blast - from this have \\ ; INV 0 [] \ gather thunks \ (\rs. \rs'. \rs = rs'\ \ INV (length thunks) rs') \ \ \ \\ + from this have \\ ; INV 0 [] \ gather thunks + \ (\rs. \rs'. \rs = rs'\ \ INV (length thunks) rs') \ \ \ \\ by fastforce moreover have \\rs. (\rs'. \rs = rs'\ \ INV (length thunks) rs') \ INV (length thunks) rs\ - using assms by (simp add: asat_simp aentails_def) + by (intro aexists_entailsL apure_precise_entailsL) (simp add: aentails_refl) ultimately show ?thesis using sstriple_consequence by blast qed @@ -827,8 +814,7 @@ qed lemma sstriple_gather_framed: notes aentails_intro [intro] fixes thunks :: \('a, 'v, 'r, 'abort, 'i prompt, 'o prompt_output) expression list\ - assumes \\p r. ucincl (INV p r)\ - and \\i res. i < length thunks \ length res = i \ \ ; INV i res \ thunks ! i \ (\v. INV (i+1) (res @ [v])) \ \ \ \\ + assumes \\i res. i < length thunks \ length res = i \ \ ; INV i res \ thunks ! i \ (\v. INV (i+1) (res @ [v])) \ \ \ \\ shows \\ ; INV 0 [] \ ((\r. (INV (length thunks) r \ \ r)) \ (\r. \ r \ \ r) \ (\r. \ r \ \ r)) \ gather thunks \ \ \ \ \ \\ proof - let ?pc = \((\r. (INV (length thunks) r \ \ r)) \ (\r. \ r \ \ r) \ (\r. \ r \ \ r))\ @@ -860,7 +846,7 @@ proof - } from this have \\ ; INV 0 [] \ ?pc \ gather thunks \ (\r. INV (length thunks) r \ ?pc) \ \ \ \\ - using assms by (auto intro!: ucincl_intros sstriple_gather_spec[where INV=\\i' res'. INV i' res' \ ?pc\ and thunks=thunks]) + using assms by (auto intro!: sstriple_gather_spec[where INV=\\i' res'. INV i' res' \ ?pc\ and thunks=thunks]) moreover have \\r. INV (length thunks) r \?pc \ INV (length thunks) r \ (\r. (INV (length thunks) r \ \ r))\ by (meson aentails_refl local.aentails_int local.asepconj_mono) diff --git a/Shallow_Separation_Logic/Weak_Triple.thy b/Shallow_Separation_Logic/Weak_Triple.thy index 5e76dda0..992790ea 100644 --- a/Shallow_Separation_Logic/Weak_Triple.thy +++ b/Shallow_Separation_Logic/Weak_Triple.thy @@ -97,12 +97,8 @@ definition striple :: (\(v,\') \ (yh \,e) \\<^sub>v \. \ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ v) \ \\Post-condition for value-evaluations\ (\(r,\') \ (yh \,e) \\<^sub>r \. \ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ r))\ \\Post-condition for return-evaluations\ -text\The striple is invariant under passage to upward closure:\ -lemma striple_upwards_closure: - shows \(\ ; \ \ \ \ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\v. \ v \ \) \ (\v. \ v \ \) \ (\a. \ a \ \)) \ - (\ ; \ \ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \)\ -by (auto simp add: atriple_upwards_closure striple_def local.asepconj_UNIV_idempotent - local.asepconj_assoc) +text\Each clause is an \<^term>\atriple\, so weak triples preserve every frame and account +exactly for the resource described by their pre- and post-conditions.\ lemma stripleI: assumes \\v s s'. s \\<^sub>v\yh \,e\ (v, s') \ \ \ (s, s') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ v\ @@ -112,8 +108,11 @@ lemma stripleI: using assms by (clarsimp simp add: striple_def return_evaluations_def value_evaluations_def abort_evaluations_def) +text\Hoisting an absorbing pure factor leaves \<^term>\\ \ \\ in the +pre-condition.\ lemma striple_hoist_pure: - shows \(\ ; \ \ \P\ \ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (P \ (\ ; \ \ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \))\ + shows \(\ ; \ \ apure P \ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ + (P \ (\ ; \ \ \ \ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \))\ by (auto simp add: striple_def atriple_hoist_pure asepconj_simp asepconj_False_True asepconj_pure_UNIV asat_simp asat_apure_distrib') @@ -128,17 +127,6 @@ lemma striple_localI: using assms by (intro stripleI; metis (mono_tags, lifting) atriple_local prod.case) -lemma striple_localI': - assumes \is_local (\\ (v,\'). \ \\<^sub>v \yh \,e\ (v,\')) \\ - and \is_local (\\ (r,\'). \ \\<^sub>r \yh \,e\ (r,\')) \\ - and \is_local (\\ (a,\'). \ \\<^sub>a \yh \,e\ (a,\')) \\ - and \\\ \' v. \ \\<^sub>v\yh \,e\ (v, \') \ \ \ \ \ \' \ \ v \ \\ - and \\\ \' r. \ \\<^sub>r\yh \,e\ (r, \') \ \ \ \ \ \' \ \ r \ \\ - and \\\ \' a. \ \\<^sub>a\yh \,e\ (a, \') \ \ \ \ \ \' \ \ a \ \\ - shows \\ ; \ \ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \\ -using assms - by (intro stripleI; metis (mono_tags, lifting) atriple_local' prod.case) - text\Weak triples are preserved under refinement of yield handlers:\ lemma striple_yield_handler_refine: @@ -383,40 +371,36 @@ using assms by (simp add: striple_def abort_evaluations_def) lemma striple_satisfiable: assumes \striple_context_no_yield ; \ \ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \\ and \is_sat \\ - and \\v. ucincl (\ v)\ - and \\r. ucincl (\ r)\ - and \\a. ucincl (\ a)\ shows \(\v. is_sat (\ v)) \ (\r. is_sat (\ r)) \ (\a. is_sat (\ a))\ proof - - from assms obtain s\<^sub>0 where \s\<^sub>0 \ \ \ UNIV\ - unfolding is_sat_def - by (meson asat_connectives_characterisation(1) asepconj_weakenI) + from assms obtain s\<^sub>0 where \s\<^sub>0 \ \\ + unfolding is_sat_def by blast moreover from this assms obtain k where \k \ deep_evaluates_nondet_basic yield_handler_no_yield e s\<^sub>0\ using deep_evaluates_nondet_basic_nonempty yield_handler_no_yield_is_nonempty by (metis all_not_in_conv) moreover { fix v \' assume \k = Success v \'\ - from this and calculation and assms have \\' \ \ v \ UNIV\ - by (clarsimp simp add: ucincl_UNIV striple_def atriple_def is_sat_def value_evaluations_def - evaluates_to_value_def) + from this and calculation and assms have \\' \ \ v\ + by (metis evaluates_to_value_def local.atripleE_emp_frame stripleE_value + striple_context_no_yield_yh) } moreover { fix r \' assume \k = Return r \'\ - from this and calculation and assms have \\' \ \ r \ UNIV\ - by (clarsimp simp add: ucincl_UNIV striple_def atriple_def is_sat_def return_evaluations_def - evaluates_to_return_def) + from this and calculation and assms have \\' \ \ r\ + by (metis evaluates_to_return_def local.atripleE_emp_frame stripleE_return + striple_context_no_yield_yh) } moreover { fix a \' assume \k = Abort a \'\ - from this and calculation and assms have \\' \ \ a \ UNIV\ - by (clarsimp simp add: ucincl_UNIV striple_def atriple_def is_sat_def abort_evaluations_def - evaluates_to_abort_def) + from this and calculation and assms have \\' \ \ a\ + by (metis evaluates_to_abort_def local.atripleE_emp_frame stripleE_abort + striple_context_no_yield_yh) } ultimately show ?thesis - using assms by (auto simp add: ucincl_alt striple_def atriple_def is_sat_def dest!: + using assms by (auto simp add: striple_def atriple_def is_sat_def dest!: deep_evaluate_basic_no_yield) qed @@ -540,7 +524,7 @@ proof - from assms have \\ ; \' \ (\' \ \) \ e \\<^sub>a\<^sub>b\<^sub>s (\r. ((\' \ \) \ \ r) \ (\' \ \)) \ (\r. ((\' \ \) \ \ r) \ (\' \ \)) \ (\a. ((\' \ \) \ \ a) \ (\' \ \))\ - using ucincl_awand FRAME by blast + using FRAME by blast from this and assms show ?thesis using WEAKEN local.awand_mp by blast qed @@ -572,25 +556,14 @@ using assms FRAME asepconj_comm by auto theorem triple_frame_rule_asepconj_multi: assumes \\ ; \\\ \ \ \ e \\<^sub>a\<^sub>b\<^sub>s (\r. \\\ \ \ r) \ (\r. \\\ \ \ r) \ (\a. \\\ \ \ a)\ - and \\\ \# \. ucincl \\ - and \ucincl \\ and \\ \# \\ shows \\ ; \\\ \ \ \ e \\<^sub>a\<^sub>b\<^sub>s (\r. \\\ \ \ r) \ (\r. \\\ \ \ r) \ (\a. \\\ \ \ a)\ proof - from \\ \# \\ obtain \' where \\ = \' + \\ using mset_subset_eq_exists_conv union_commute by metis - from this and \\ \# \\ and \\\ \# \. ucincl \\ have \\\ \# \. ucincl \\ - by auto - from this and assms have \ucincl (\\\ \ \)\ - using asepconj_multi_ucincl ucincl_asepconj by auto - from \\ = \' + \\ and \\\ \# \. ucincl \\ have \\\ \# \'. ucincl \\ - by auto - from this have \ucincl (\\\')\ - using local.asepconj_multi_ucincl by auto - from \\ = \' + \\ have \\\\ = \\\' \ \\\\ + from this have \\\\ = \\\' \ \\\\ using asepconj_multi_split' by auto - from \ucincl (\\\')\ and \ucincl (\\\ \ \)\ - and \\ ; \\\ \ \ \ e \\<^sub>a\<^sub>b\<^sub>s (\r. \\\ \ \ r) \ (\r. \\\ \ \ r) \ (\a. \\\ \ \ a)\ + from \\ ; \\\ \ \ \ e \\<^sub>a\<^sub>b\<^sub>s (\r. \\\ \ \ r) \ (\r. \\\ \ \ r) \ (\a. \\\ \ \ a)\ have \\ ; \\\' \ (\\\ \ \) \ e \\<^sub>a\<^sub>b\<^sub>s (\r. \\\' \ (\\\ \ \ r)) \ (\r. \\\' \ (\\\ \ \ r)) \ (\r. \\\' \ (\\\ \ \ r))\ @@ -602,15 +575,13 @@ qed theorem triple_frame_rule_asepconj_multi_single: notes asepconj_simp [simp] assumes \\ ; \ \ \ \ e \\<^sub>a\<^sub>b\<^sub>s (\r. \ \ \ r) \ (\r. \ \ \ r) \ (\a. \ \ \ a)\ - and \\\ \# \. ucincl \\ - and \ucincl \\ and \\ \# \\ shows \\ ; \\\ \ \ \ e \\<^sub>a\<^sub>b\<^sub>s (\r. \\\ \ \ r) \ (\r. \\\ \ \ r) \ (\a. \\\ \ \ a)\ proof - from assms have \\ ; \\{#\#} \ \ \ e \\<^sub>a\<^sub>b\<^sub>s (\r. \\{#\#} \ \ r) \ (\r. \\{#\#} \ \ r) \ (\a. \\{#\#} \ \ a)\ - by (simp add: local.asepconj_multi_def) + by (simp add: local.asepconj_multi_single') moreover from \\ \# \\ have \{#\#} \# \\ by auto ultimately show ?thesis @@ -715,19 +686,21 @@ lemma striple_skipI: shows \\ ; \ \ skip \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\_. \) \ \ \ \\ by (auto intro!: stripleI simp add: atriple_def urust_eval_predicate_skip) +text\Stability under every frame is exactly entailment; the reverse direction uses the +\<^term>\emp\ frame.\ lemma aentails_after_all_asepconjs: - shows \(\\. ucincl \ \ (\ \ \ \ \ \ \)) \ (\ \ \ \ \)\ - by (metis (no_types, lifting) local.asepconj_ident2 local.asepconj_mono local.asepconj_swap_top local.ucincl_UNIV - local.ucincl_alt' local.ucincl_asepconjR) + shows \(\\. (\ \ \ \ \ \ \)) \ (\ \ \)\ + by (metis local.asepconj_emp_unit(1) local.asepconj_mono2) text\Executing a literal does not modify the state in anyway way, but does return the literal value. It also always succeeds:\ lemma striple_literalI: - shows \\ ; \ \ \v \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\rv. \rv = v\) \ \ \ \\ -by (auto intro!: stripleI simp add: atriple_def urust_eval_predicate_literal asepconj_simp) + shows \\ ; \ \ \v \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\rv. apure (rv = v)) \ \ \ \\ + by (auto intro!: stripleI simp add: atriple_def urust_eval_predicate_literal asepconj_simp + asepconj_False_True) lemma striple_literal: - shows \(\ ; \ \ \v \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ v \ \)\ + shows \(\ ; \ \ \v \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ v)\ apply (clarsimp simp add: striple_def atriple_def urust_eval_action_simps) using aentails_after_all_asepconjs aentails_def apply blast done @@ -739,7 +712,7 @@ by (auto simp add: is_sat_def asat_def asepconj_def) lemma striple_assert_val: shows \(\ ; \ \ assert_val v \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ - (v \ \ \ \ \ \ ()) \ (\v \ \ \ \ \ \ AssertionFailed)\ + (v \ \ \ \ ()) \ (\v \ \ \ \ AssertionFailed)\ proof (cases v) case True then show ?thesis @@ -748,14 +721,13 @@ next case False show ?thesis proof - - have \\ \ UNIV \ \ AssertionFailed\ - if \\\ \. ucincl \ \ \ \ \ \ \ \ \ \ \ AssertionFailed \ \\ - by (metis aentails_after_all_asepconjs aentails_def local.asepconj_comm that) + have \\ \ \ AssertionFailed\ + if \\\ \. \ \ \ \ \ \ \ \ \ AssertionFailed \ \\ + by (metis aentails_after_all_asepconjs aentails_def that) moreover have \\ \ \ AssertionFailed \ \\ - if \\ \ \ \ \ AssertionFailed\ - and \ucincl \\ \\ \ \ \ \\ + if \\ \ \ AssertionFailed\ and \\ \ \ \ \\ for \ \ - using that by (metis aentailsE aentails_after_all_asepconjs local.asepconj_comm) + using that by (metis aentailsE aentails_after_all_asepconjs) ultimately show ?thesis using False by (auto simp add: striple_def atriple_def urust_eval_action_simps asepconj_False_True asepconj_simp) qed @@ -763,77 +735,76 @@ qed lemma striple_assert: shows \(\ ; \ \ \ assert!(v) \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ - (v \ \ \ \ \ \ ()) \ (\v \ \ \ \ \ \ AssertionFailed)\ + (v \ \ \ \ ()) \ (\v \ \ \ \ AssertionFailed)\ by (simp add: assert_def micro_rust_simps striple_assert_val) lemma striple_assert_eq: shows \(\ ; \ \ \ assert_eq!(v,w) \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ - (v=w \ \ \ \ \ \ ()) \ (v \ w \ \ \ \ \ \ AssertionFailed)\ + (v=w \ \ \ \ ()) \ (v \ w \ \ \ \ AssertionFailed)\ by (simp add: assert_eq_def assert_eq_val_def micro_rust_simps striple_assert_val) text\The \<^verbatim>\return_func\ command always succeeds and returns the given value:\ lemma striple_return_valI: - shows \\ ; \ \ return_val v \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ (\rv. \rv = v\) \ \\ -by (auto intro!: stripleI simp add: atriple_def urust_eval_predicate_return asepconj_simp) + shows \\ ; \ \ return_val v \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ (\rv. apure (rv = v)) \ \\ + by (auto intro!: stripleI simp add: atriple_def urust_eval_predicate_return asepconj_simp + asepconj_False_True) lemma striple_return_val: - shows \(\ ; \ \ return_val v \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ v \ \)\ + shows \(\ ; \ \ return_val v \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ v)\ using aentails_after_all_asepconjs by (force simp: aentails_def striple_def atriple_def urust_eval_action_simps) lemma striple_returnI: - shows \\ ; \ \ return_func (\v) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ (\rv. \rv = v\) \ \\ + shows \\ ; \ \ return_func (\v) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ (\rv. apure (rv = v)) \ \\ by (intro stripleI; simp add: return_func_def urust_eval_predicate_bind urust_eval_predicate_return urust_eval_predicate_literal apure_def atriple_post_true) lemma striple_return: - shows \(\ ; \ \ return_func (\v) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ v \ \)\ + shows \(\ ; \ \ return_func (\v) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ v)\ using aentails_after_all_asepconjs by (force simp: aentails_def striple_def atriple_def return_func_def urust_eval_action_simps) corollary striple_noneI: - shows \\ ; \ \ `None \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\rv. \rv = None\) \ \ \ \\ + shows \\ ; \ \ `None \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\rv. apure (rv = None)) \ \ \ \\ by (unfold none_def, rule striple_literalI) corollary striple_trueI: - shows \\ ; \ \ `True \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\rv. \rv = True\) \ \ \ \\ + shows \\ ; \ \ `True \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\rv. apure (rv = True)) \ \ \ \\ by (unfold true_def, rule striple_literalI) corollary striple_falseI: - shows \\ ; \ \ `False \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\rv. \rv = False\) \ \ \ \\ + shows \\ ; \ \ `False \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\rv. apure (rv = False)) \ \ \ \\ by (unfold false_def, rule striple_literalI) corollary striple_someI: notes asepconj_simp [simp] - shows \\ ; \ \ `Some (\x) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\rv. \rv = Some x\) \ \ \ \\ + shows \\ ; \ \ `Some (\x) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\rv. apure (rv = Some x)) \ \ \ \\ by (intro stripleI; simp add: urust_eval_predicate_bind return_func_def micro_rust_simps some_def urust_eval_predicate_return urust_eval_predicate_literal apure_def atriple_post_true) text\Abort and panic terminate execution of the program:\ lemma striple_abort: - shows \(\ ; \ \ abort m \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ m \ \)\ + shows \(\ ; \ \ abort m \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ m)\ using aentails_after_all_asepconjs by (force simp: aentails_def striple_def atriple_def return_func_def urust_eval_action_simps) text\Panic terminates execution of the program:\ lemma striple_panic: - shows \(\ ; \ \ panic msg \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ (Panic msg) \ \)\ + shows \(\ ; \ \ panic msg \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ (Panic msg))\ by (simp add: striple_abort) text\Pause / Breakpoint\ lemma striple_pause: - assumes \\r. ucincl (\ r)\ - shows \(\ ; \ \ \ \\\\\ \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \)\ -using assms by (simp add: striple_def urust_eval_action_simps atriple_def) + shows \(\ ; \ \ \ \\\\\ \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \)\ +by (simp add: striple_def urust_eval_action_simps atriple_def) lemma striple_pause': - assumes \\r. ucincl (\ r)\ - shows \(\ ; \ \ \ \\\\\ \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ ())\ -using assms unfolding is_valid_striple_context_def + shows \(\ ; \ \ \ \\\\\ \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ ())\ + unfolding is_valid_striple_context_def apply (clarsimp simp add: striple_def urust_eval_action_simps atriple_def) using aentails_after_all_asepconjs - apply (metis aentails_def local.asepconj_strengthenE local.ucincl_UNIV) + apply (metis aentails_def) done text\Various types of log events:\ @@ -843,20 +814,17 @@ lemma striple_log: by (simp add: striple_def urust_eval_action_simps atriple_def is_valid_striple_context_def) lemma striple_log': - assumes \\r. ucincl (\ r)\ - shows \(\ ; \ \ \ \\\ \p\ \l\ \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ ())\ -using assms + shows \(\ ; \ \ \ \\\ \p\ \l\ \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ ())\ apply (clarsimp simp add: striple_def urust_eval_action_simps atriple_def is_valid_striple_context_def) using aentails_after_all_asepconjs - apply (metis aentails_def local.asepconj_strengthenE local.ucincl_UNIV) + apply (metis aentails_def) done text\Fatal errors\ lemma striple_fatal: assumes \is_aborting_striple_context \\ - and \\r. ucincl (\ r)\ shows \(\ ; \ \ \ fatal!(msg) \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \)\ using assms by (simp add: striple_def urust_eval_action_simps atriple_def is_aborting_striple_context_def) @@ -927,23 +895,41 @@ using assms by - (intro stripleI; elim stripleE_value stripleE_abort; simp add: urust_eval_predicate_call) lemma striple_call_funliteral: - shows \(\ ; \ \ \ \f1\\<^sub>1 (v0) \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ (f1 v0) \ \)\ - and \(\ ; \ \ \ \f2\\<^sub>2 (v0, v1) \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ (f2 v0 v1) \ \)\ - and \(\ ; \ \ \ \f3\\<^sub>3 (v0, v1, v2) \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ (f3 v0 v1 v2) \ \)\ - and \(\ ; \ \ \ \f4\\<^sub>4 (v0, v1, v2, v3) \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ (f4 v0 v1 v2 v3) \ \)\ - and \(\ ; \ \ \ \f5\\<^sub>5 (v0, v1, v2, v3, v4) \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ (f5 v0 v1 v2 v3 v4) \ \)\ - and \(\ ; \ \ \ \f6\\<^sub>6 (v0, v1, v2, v3, v4, v5) \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ (f6 v0 v1 v2 v3 v4 v5) \ \)\ - and \(\ ; \ \ \ \f7\\<^sub>7 (v0, v1, v2, v3, v4, v5, v6) \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ (f7 v0 v1 v2 v3 v4 v5 v6) \ \)\ - and \(\ ; \ \ \ \f8\\<^sub>8 (v0, v1, v2, v3, v4, v5, v6, v7) \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ (f8 v0 v1 v2 v3 v4 v5 v6 v7) \ \)\ + shows \(\ ; \ \ \ \f1\\<^sub>1 (v0) \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ (f1 v0))\ + and \(\ ; \ \ \ \f2\\<^sub>2 (v0, v1) \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ (f2 v0 v1))\ + and \(\ ; \ \ \ \f3\\<^sub>3 (v0, v1, v2) \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ (f3 v0 v1 v2))\ + and \(\ ; \ \ \ \f4\\<^sub>4 (v0, v1, v2, v3) \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ (f4 v0 v1 v2 v3))\ + and \(\ ; \ \ \ \f5\\<^sub>5 (v0, v1, v2, v3, v4) \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ (f5 v0 v1 v2 v3 v4))\ + and \(\ ; \ \ \ \f6\\<^sub>6 (v0, v1, v2, v3, v4, v5) \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ (f6 v0 v1 v2 v3 v4 v5))\ + and \(\ ; \ \ \ \f7\\<^sub>7 (v0, v1, v2, v3, v4, v5, v6) \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ (f7 v0 v1 v2 v3 v4 v5 v6))\ + and \(\ ; \ \ \ \f8\\<^sub>8 (v0, v1, v2, v3, v4, v5, v6, v7) \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ (f8 v0 v1 v2 v3 v4 v5 v6 v7))\ using aentails_after_all_asepconjs by (auto simp add: striple_def urust_eval_action_simps micro_rust_simps atriple_def aentails_def) (blast, meson aentailsE aentails_after_all_asepconjs)+ +text\\<^term>\get\ observes the full machine state, so \<^term>\has f v\ must be +upwards closed to lift it from the owned substate across an arbitrary frame.\ lemma striple_getI: - assumes \ucincl (has f v)\ - shows \\; has f v \ get f \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\x. \x = v\ \ has f v) \ \ \ \\ -using assms by (intro stripleI; clarsimp simp add: urust_eval_predicate_get urust_eval_predicate_literal - atriple_def) (metis asat_def local.asat_apure_distrib local.asepconj_assoc - local.asepconj_strengthenE local.has_def local.ucincl_asepconj mem_Collect_eq) + assumes ucincl: \ucincl (has f v)\ + shows \\; has f v \ get f \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\x. apure (x = v) \ has f v) \ \ \ \\ +proof (intro stripleI; (clarsimp simp add: urust_eval_predicate_get + urust_eval_predicate_literal)?) + fix s :: \'a\ + show \has f v \ (s, s) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k apure (f s = v) \ has f v\ + proof (rule atripleI) + fix \ + assume \s \ has f v \ \\ + \\Upwards closure lifts \<^term>\has f v\ from its owned substate to + \<^term>\s\.\ + from this and ucincl have \s \ has f v\ + by (metis asepconjE asat_weaken) + then have \f s = v\ + by (simp add: asat_def has_def) + then have \apure (f s = v) \ has f v = has f v\ + by (simp add: asepconj_ident4 ucincl) + then show \s \ (apure (f s = v) \ has f v) \ \\ + using \s \ has f v \ \\ by simp + qed +qed lemma striple_putI: assumes \\x. x \ has f v \ g x \ has f v'\ @@ -957,67 +943,78 @@ subsection\Defining triples for numeric and bitwise operators\ lemma striple_word_add_no_wrapI: fixes x y :: \'l::{len} word\ - shows \\ ; \unat x + unat y < 2^(LENGTH('l))\ \ \ x + y \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = x + y\) \ \ \ \\ - by (intro stripleI; clarsimp simp add: urust_eval_predicate_add_no_wrap apure_def asepconj_simp - atriple_post_true atriple_pre_false) + shows \\ ; \unat x + unat y < 2^(LENGTH('l))\ + \ \ x + y \ + \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = x + y\) \ \ \ \\ + by (intro stripleI; clarsimp simp add: urust_eval_predicate_add_no_wrap asepconj_simp + atriple_refl atriple_pre_false) lemma striple_word_mul_no_wrapI: fixes x y :: \'l::{len} word\ - shows \\ ; \unat x * unat y < 2^(LENGTH('l))\ \ \ x * y \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = x * y\) \ \ \ \\ - by (intro stripleI; clarsimp simp add: urust_eval_predicate_mul_no_wrap apure_def asepconj_simp - atriple_post_true atriple_pre_false) + shows \\ ; \unat x * unat y < 2^(LENGTH('l))\ + \ \ x * y \ + \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = x * y\) \ \ \ \\ + by (intro stripleI; clarsimp simp add: urust_eval_predicate_mul_no_wrap asepconj_simp + atriple_refl atriple_pre_false) lemma striple_word_sub_no_wrapI: fixes x y :: \'l::{len} word\ - shows \\ ; \y \ x\ \ \ x - y \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = x - y\) \ \ \ \\ - by (intro stripleI; clarsimp simp add: urust_eval_predicate_sub_no_wrap apure_def asepconj_simp - atriple_post_true atriple_pre_false word_le_nat_alt) + shows \\ ; \y \ x\ \ \ x - y \ + \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = x - y\) \ \ \ \\ + by (intro stripleI; clarsimp simp add: urust_eval_predicate_sub_no_wrap asepconj_simp + atriple_refl atriple_pre_false word_le_nat_alt) lemma striple_word_udivI: fixes x y :: \'l::{len} word\ - shows \\ ; \y \ 0\ \ \ x / y \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = x div y\) \ \ \ \\ - by (intro stripleI; clarsimp simp add: urust_eval_predicate_div apure_def asepconj_simp - atriple_post_true unat_eq_zero atriple_pre_false) + shows \\ ; \y \ 0\ \ \ x / y \ + \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = x div y\) \ \ \ \\ + by (intro stripleI; clarsimp simp add: urust_eval_predicate_div asepconj_simp + atriple_refl unat_eq_zero atriple_pre_false) lemma striple_word_umodI: fixes x y :: \'l::{len} word\ - shows \\ ; \y \ 0\ \ \ x % y \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = x mod y\) \ \ \ \\ -by (intro stripleI; clarsimp simp add: urust_eval_predicate_mod apure_def asepconj_simp - atriple_post_true unat_eq_zero atriple_pre_false) + shows \\ ; \y \ 0\ \ \ x % y \ + \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = x mod y\) \ \ \ \\ +by (intro stripleI; clarsimp simp add: urust_eval_predicate_mod asepconj_simp + atriple_refl unat_eq_zero atriple_pre_false) lemma striple_word_shift_leftI: fixes x :: \'l0::{len} word\ and y :: \64 word\ - shows \\ ; \unat y < LENGTH('l0)\ \ \ x << y \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = push_bit (unat y) x\) \ \ \ \\ -by (intro stripleI; clarsimp simp add: asepconj_simp urust_eval_predicate_shift_left apure_def - atriple_post_true atriple_pre_false) + shows \\ ; \unat y < LENGTH('l0)\ + \ \ x << y \ + \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = push_bit (unat y) x\) \ \ \ \\ +by (intro stripleI; clarsimp simp add: asepconj_simp urust_eval_predicate_shift_left + atriple_refl atriple_pre_false) lemma striple_word_shift_rightI: fixes x :: \'l0::{len} word\ and y :: \64 word\ - shows \\ ; \unat y < LENGTH('l0)\ \ \ x >> y \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = drop_bit (unat y) x\) \ \ \ \\ -by (intro stripleI; clarsimp simp add: urust_eval_predicate_shift_right apure_def asepconj_simp - atriple_post_true atriple_pre_false) + shows \\ ; \unat y < LENGTH('l0)\ + \ \ x >> y \ + \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = drop_bit (unat y) x\) \ \ \ \\ +by (intro stripleI; clarsimp simp add: urust_eval_predicate_shift_right asepconj_simp + atriple_refl atriple_pre_false) lemma striple_bitwise_orI: fixes x y :: \'l::{len} word\ - shows \\ ; \ \ \ x | y \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = x OR y\) \ \ \ \\ -by (intro stripleI; clarsimp simp add: urust_eval_predicate_or apure_def atriple_post_true) + shows \\ ; emp \ \ x | y \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = x OR y\) \ \ \ \\ +by (intro stripleI; clarsimp simp add: urust_eval_predicate_or asepconj_simp atriple_refl) lemma striple_bitwise_andI: fixes x y :: \'l::{len} word\ - shows \\ ; \ \ \ x & y \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = x AND y\) \ \ \ \\ -by (intro stripleI; clarsimp simp add: urust_eval_predicate_and apure_def atriple_post_true) + shows \\ ; emp \ \ x & y \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = x AND y\) \ \ \ \\ +by (intro stripleI; clarsimp simp add: urust_eval_predicate_and asepconj_simp atriple_refl) lemma striple_bitwise_xorI: fixes x y :: \'l::{len} word\ - shows \\ ; \ \ \ x ^ y \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = x XOR y\) \ \ \ \\ -by (intro stripleI; clarsimp simp add: urust_eval_predicate_xor apure_def atriple_post_true) + shows \\ ; emp \ \ x ^ y \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = x XOR y\) \ \ \ \\ +by (intro stripleI; clarsimp simp add: urust_eval_predicate_xor asepconj_simp atriple_refl) lemma striple_bitwise_notI: fixes x :: \'l::{len} word\ - shows \\ ; \ \ \ !x \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = NOT x\) \ \ \ \\ -by (intro stripleI; clarsimp simp add: urust_eval_predicate_not apure_def atriple_post_true) + shows \\ ; emp \ \ !x \ \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. \r = NOT x\) \ \ \ \\ +by (intro stripleI; clarsimp simp add: urust_eval_predicate_not asepconj_simp atriple_refl) subsection\Loops\ @@ -1045,8 +1042,7 @@ qed lemma striple_raw_for_loop_framed: notes aentails_intro [intro] fixes INV :: \'t list \ 't list \ 'a assert\ - assumes \\p t. ucincl (INV p t)\ - and \\past cur todo. \ ; INV past (cur # todo) \ f cur \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\_. INV (past @ [cur]) todo) \ \ \ \\ + assumes \\past cur todo. \ ; INV past (cur # todo) \ f cur \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\_. INV (past @ [cur]) todo) \ \ \ \\ shows \\ ; INV [] xs \ ((INV xs [] \ \ ()) \ (\r. \ r \ \ r) \ (\a. \ a \ \ a)) \ raw_for_loop xs f \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \\ proof - @@ -1119,7 +1115,7 @@ proof - using assms by auto then have \\ ; INV xs i \ ?pc \ f (xs ! i) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\_. INV xs (i+1) \ ?pc) \ (\r. \ r \ ?pc) \ (\a. \ a \ ?pc)\ - using assms by (auto intro!: striple_frame_rule ucincl_Int ucincl_awand ucincl_inter) + using assms by (auto intro!: striple_frame_rule) moreover have \\r. \ r \ ?pc \ \ r\ proof - have \\r. \ r \ (\r. \ r \ \ r) \ \ r\ @@ -1155,11 +1151,12 @@ lemma gather_spec': using assms proof (induction thunks arbitrary: INV acc) case Nil - have \(\x. (if x = [] then UNIV else {}) \ INV 0 x) = (\x. (if x = [] then UNIV \ INV 0 x else {}))\ - by (auto simp: split: if_splits) - also have \... = UNIV \ INV 0 []\ by auto - finally show ?case - by (auto simp: gather'_nil striple_def apure_def asepconj_swap_top urust_eval_action_literal atriple_refl') + have \INV 0 [] \ \acc = acc @ []\ \ INV 0 []\ + by (simp add: asepconj_simp aentails_refl) + from this have \INV 0 [] \ (\rs'. \acc = acc @ rs'\ \ INV 0 rs')\ + by (rule aexists_entailsR) + from this show ?case + by (simp add: gather'_nil striple_literal) next case (Cons t thunks) then have first: \\ ; INV 0 [] \ t \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\v. INV 1 [v]) \ \ \ \\ @@ -1188,8 +1185,7 @@ lemma gather_spec: notes aentails_intro [intro] fixes INV :: \nat \ 'v list \ 'a assert\ and thunks :: \('a, 'v, 'r, 'abort, 'i prompt, 'o prompt_output) expression list\ - assumes \\i ls. ucincl (INV i ls)\ - and \\i ls. i < length thunks \ length ls = i \ + assumes \\i ls. i < length thunks \ length ls = i \ \ ; INV i ls \ thunks ! i \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\v. INV (i+1) (ls @ [v])) \ \ \ \\ shows \\ ; INV 0 [] \ gather thunks \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\rs. INV (length thunks) rs) \ \ \ \\ proof - @@ -1199,7 +1195,7 @@ proof - from this have \\ ; INV 0 [] \ gather thunks \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\rs. \rs'. \rs = rs'\ \ INV (length thunks) rs') \ \ \ \\ by fastforce moreover have \\rs. (\rs'. \rs = rs'\ \ INV (length thunks) rs') \ INV (length thunks) rs\ - using assms by (simp add: asat_simp aentails_def) + by (intro aexists_entailsL apure_precise_entailsL) (simp add: aentails_refl) ultimately show ?thesis using striple_consequence by blast qed @@ -1207,8 +1203,7 @@ qed lemma striple_gather_framed: notes aentails_intro [intro] fixes thunks :: \('a, 'v, 'r, 'abort, 'i prompt, 'o prompt_output) expression list\ - assumes \\p r. ucincl (INV p r)\ - and \\i res. i < length thunks \ length res = i \ \ ; INV i res \ thunks ! i \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\v. INV (i+1) (res @ [v])) \ \ \ \\ + assumes \\i res. i < length thunks \ length res = i \ \ ; INV i res \ thunks ! i \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\v. INV (i+1) (res @ [v])) \ \ \ \\ shows \\ ; INV 0 [] \ ((\r. (INV (length thunks) r \ \ r)) \ (\r. \ r \ \ r) \ (\a. \ a \ \ a)) \ gather thunks \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \\ proof - let ?pc = \(\r. (INV (length thunks) r \ \ r)) \ (\r. \ r \ \ r) \ (\a. \ a \ \ a)\ @@ -1239,7 +1234,7 @@ proof - by - (rule striple_consequence, assumption, rule aentails_refl, rule aentails_refl, force) } from this have \\ ; INV 0 [] \ ?pc \ gather thunks \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\r. INV (length thunks) r \ ?pc) \ \ \ \\ - using assms by (auto intro!: ucincl_intros gather_spec[where INV=\\i' res'. INV i' res' \ ?pc\ and thunks=thunks]) + using assms by (auto intro!: gather_spec[where INV=\\i' res'. INV i' res' \ ?pc\ and thunks=thunks]) moreover have \\r. INV (length thunks) r \ ?pc \ INV (length thunks) r \ (\r. (INV (length thunks) r \ \ r))\ by (meson aentails_refl local.aentails_int local.asepconj_mono) diff --git a/Shallow_Separation_Logic/Weakest_Precondition.thy b/Shallow_Separation_Logic/Weakest_Precondition.thy index ea6ddb71..4f64e50c 100644 --- a/Shallow_Separation_Logic/Weakest_Precondition.thy +++ b/Shallow_Separation_Logic/Weakest_Precondition.thy @@ -116,33 +116,40 @@ text \In this section, we demonstrate how to transport properties of sstri of the weakest precondition. The proofs are purely formal and solely rely on the universal property of the weakest precondition, but not its concrete definition.\ -text \First, the weakest precondition is always upwards closed:\ -lemma ucincl_wp'I [ucincl_intros]: - shows \ucincl (\\

\ e \ \ \)\ - \\For sake of demonstration, we go through this proof in small steps:\ - \\First, we need to use a definition of \<^term>\ucincl\ which only uses \<^verbatim>\_ \ \\, - but not \<^verbatim>\\\ itself. Luckily, \<^verbatim>\ucincl_alt'\ provides such:\ - apply (simp add: ucincl_alt') - \\Next, we apply the universal property of \<^verbatim>\\\

\ on both sides:\ - apply (simp add: sstriple_wp_iff) - \\This has transformed the goal to an assertion about sstriples that we have proved before.\ - apply (simp flip: sstriple_upwards_closure) - done - -text \The weakest precondition is unchanged when passing to the upwards closure of the -post-conditions:\ -lemma wp_upwards_closure: - shows \(\\

\ e \ \ \) = \\

\ e \ (\r. (\ r \ \)) \\ - and \(\\

\ e \ \ \) = \\

\ e (\r. (\ r \ \)) \ \\ - and \(\\

\ e \ \ \) = \\

\ e \ \ (\a. \ a \ \)\ - and \(\\

\ e \ \ \) = \\

\ e (\r. (\ r \ \)) (\r. (\ r \ \)) (\a. (\ a \ \))\ - \\Here we use \<^verbatim>\aentails_yonedaI\ to transform the goals into statements involving only - \<^verbatim>\_ \ \\

_\. This allows us to apply the universal property \<^verbatim>\sstriple_wp_iff\, thereby - reducing the statement to known upwards closure properties of sstriple:\ - by (auto - intro!: aentails_yonedaI - simp add: sstriple_wp_iff - simp flip: sstriple_upwards_closure) +text \An exact weakest precondition is upwards closed when all three post-condition families +are. Registering this rule with \<^verbatim>\ucincl_intros\ exposes those obligations to +\<^verbatim>\ucincl_solve\.\ +lemma ucincl_wpI [ucincl_intros]: + assumes psi: \\v. ucincl (\ v)\ + and rho: \\r. ucincl (\ r)\ + and theta: \\a. ucincl (\ a)\ + shows \ucincl (\\

\ e \ \ \)\ + \\\<^verbatim>\ucincl_alt'\ puts the assertion to the right of an entailment, where + the universal property of \<^term>\\\

\ applies.\ +proof (unfold ucincl_alt', intro allI iffI) + fix \ + assume \\ \ \ \ \\

\ e \ \ \\ + \\This direction only weakens the pre-condition.\ + moreover have \\ \ \ \ \\ + by (rule asepconj_mono6[OF aentails_refl aentails_true]) + ultimately show \\ \ \\

\ e \ \ \\ + by (rule aentails_trans[rotated]) +next + fix \ + \\Use the universal property to expose a triple.\ + assume \\ \ \\

\ e \ \ \\ + from this have \\ ; \ \ e \ \ \ \ \ \\ + by (rule wp_to_sstriple) + \\Frame with \<^term>\\\; upwards-closed post-conditions absorb the added + resource.\ + from this have \\ ; \ \ \ \ e \ (\v. \ v \ \) \ (\r. \ r \ \) \ (\a. \ a \ \)\ + by (rule sstriple_frame_rule) + from this have \\ ; \ \ \ \ e \ \ \ \ \ \\ + by (simp add: psi rho theta asepconj_ident2) + \\Fold the framed triple back through the universal property.\ + from this show \\ \ \ \ \\

\ e \ \ \\ + by (rule wp_is_weakest_precondition) +qed text\The transitivity/consequence rule for triples yields a similar rule for weakest preconditions. It allows us to strengthen preconditions and weaken postconditions:\ @@ -176,7 +183,6 @@ theorem wp_frame_rule_asepconj_multi_singleI: \\

\ e (\r. \\{# \ \ drop_nth i lst #} \ \ r) (\r. \\{# \ \ drop_nth i lst #} \ \ r) (\r. \\{# \ \ drop_nth i lst #} \ \ r)\ - and \ucincl \\ and \i < length lst\ shows \\\{# \ \ lst #} \ \ \ \\

\ e \ \ \\ using assms sstriple_frame_rule_asepconj_multi_singleI' wp_sstriple_iff by blast @@ -184,15 +190,20 @@ using assms sstriple_frame_rule_asepconj_multi_singleI' wp_sstriple_iff by blast lemma sstriple_pure_to_wp': notes asat_simp [simp] and asepconj_simp [simp] - assumes \ucincl (\ x)\ - and \\; \ \ e \ (\v. \v = x\) \ \ \ \\ + assumes E: \\; emp \ e \ (\v. \v = x\) \ \ \ \\ shows \\ x \ \\

\ e \ \ \\ proof - - from assms have \\; \ \ \ x \ e \ (\v. \v = x\ \ \ x) \ (\_. \ \ \ x) \ (\_. \ \ \ x)\ - by (intro sstriple_frame_rule, auto simp add: bot_fun_def) - from assms and this show \\ x \ \\

\ e \ \ \\ - by (intro wp_is_weakest_precondition; clarsimp) - (rule sstriple_consequence, auto simp add: aentails_def) + from E have framed: + \\; emp \ \ x \ e \ (\v. \v = x\ \ \ x) \ (\_. \ \ \ x) \ (\_. \ \ \ x)\ + by (intro sstriple_frame_rule) (auto simp add: bot_fun_def) + \\The pure factor of the post-condition owns nothing, so it can be hoisted out without loss.\ + have post: \\v. \v = x\ \ \ x \ \ v\ + by (intro apure_precise_entailsL) (simp add: aentails_refl) + have \\; \ x \ e \ \ \ \ \ \\ + by (intro sstriple_consequence[OF framed]) + (auto simp add: post aentails_refl asepconj_emp_unit asepconj_bot_zero2 bot_aentails_all) + from this show \\ x \ \\

\ e \ \ \\ + by (rule wp_is_weakest_precondition) qed text \This is a useful lemma for transporting Hoare triple facts of straight-line code (guaranteed @@ -206,7 +217,7 @@ proof - (\v. post v \ (\v'. post v' \ \ v')) \ (\_. \ \ (\v'. post v' \ \ v')) \ (\_. \ \ (\v'. post v' \ \ v'))\ - by (intro sstriple_frame_rule; clarsimp simp add: bot_fun_def ucincl_intros intro!:ucincl_Int) + by (intro sstriple_frame_rule; clarsimp simp add: bot_fun_def) moreover have \\r. post r \ (\v'. post v' \ \ v') \ \ r\ by (metis (no_types, lifting) aentails_refl aforall_entailsL asepconj_comm awand_adjoint) ultimately have \\; pre \ (\v. post v \ \ v) \ e \ \ \ \ \ \\ @@ -225,13 +236,11 @@ proof - (\v. post v \ ?frame) \ (\_. \ \ ?frame) \ (\r. ab r \ ?frame)\ - by (intro sstriple_frame_rule; clarsimp simp add: bot_fun_def ucincl_intros intro!:ucincl_Int) + by (intro sstriple_frame_rule; clarsimp simp add: bot_fun_def) moreover have B: \\r. ab r \ ?frame \ \ r\ - by (metis (no_types, lifting) aentails_refl_eq inf_commute aentails_fold_def - aentails_inter_weaken2 aforall_entailsL asepconj_mono3) + by (rule awand_forall_inter_counit) moreover have C: \\r. post r \ ?frame \ \ r\ - by (metis (no_types, lifting) aentails_refl_eq aentails_fold_def - aentails_inter_weaken2 aforall_entailsL asepconj_mono3) + by (rule awand_forall_inter_counit) have \\; pre \ ?frame \ e \ \ \ \ \ \\ using sstriple_consequence [OF A] by (simp add: B C aentails_refl local.bot_aentails_all) @@ -249,7 +258,7 @@ proof - from assms have \\; pre \ (\v. post v \ \ v) \ e \ (\v. post v \ (\v'. post v' \ \ v')) \ (\r. ((\v'. post v' \ \ v') \ \ r) \ (\v'. post v' \ \ v')) \ (\r. ((\v'. post v' \ \ v') \ \ r) \ (\v'. post v' \ \ v'))\ - by (intro sstriple_frame_rule; clarsimp simp add: ucincl_intros intro!: ucincl_Int) + by (intro sstriple_frame_rule; clarsimp) moreover have \pre \ (\v. post v \ \ v) \ pre \ (\v. post v \ \ v)\ by (intro aentails_refl) moreover have \\r. post r \ (\v'. post v' \ \ v') \ \ r\ @@ -261,7 +270,7 @@ proof - ultimately have \\; pre \ (\v. post v \ \ v) \ e \ \ \ \ \ \\ by (rule sstriple_consequence) then show \pre \ (\v. post v \ \ v) \ \\

\ e \ \ \\ - using assms by (auto intro!: wp_is_weakest_precondition ucincl_asepconj ucincl_Int ucincl_awand) + using assms by (auto intro!: wp_is_weakest_precondition) qed subsection\Local axioms for Micro Rust expressions\ @@ -287,133 +296,120 @@ named_theorems micro_rust_wp_ex_intros lemma wp_pause: notes asepconj_simp [simp] - assumes \\r. ucincl (\ r)\ - shows \\\

\ \ \\\\\ \ \ \ \ = \ ()\ - using assms by (auto intro!: aentails_yonedaI simp add: sstriple_wp_iff sstriple_pause') + shows \\\

\ \ \\\\\ \ \ \ \ = \ ()\ + by (auto intro!: aentails_yonedaI simp add: sstriple_wp_iff sstriple_pause') text\The following is deliberately not marked as \<^verbatim>\micro_rust_wp_intros\ so automation does not silently go over it.\ \\NOTE: This lemma is not used at present, but seems worth keeping.\ lemma wp_pauseI: - assumes \\r. ucincl (\ r)\ - and \\ \ \ ()\ + assumes \\ \ \ ()\ shows \\ \ \\

\ \ \\\\\ \ \ \ \\ using assms by (simp add: wp_pause) lemma wp_log: notes asepconj_simp [simp] - assumes \\r. ucincl (\ r)\ - shows \\\

\ \ \\\ \p\ \l\ \ \ \ \ = \ ()\ -using assms by (auto intro!: aentails_yonedaI simp add: sstriple_wp_iff sstriple_log') + shows \\\

\ \ \\\ \p\ \l\ \ \ \ \ = \ ()\ +by (auto intro!: aentails_yonedaI simp add: sstriple_wp_iff sstriple_log') lemma wp_logI [micro_rust_wp_intros]: - assumes \\r. ucincl (\ r)\ - and \\ \ \ ()\ + assumes \\ \ \ ()\ shows \\ \ \\

\ \ \\\ \p\ \l\ \ \ \ \\ using assms by (simp add: wp_log) lemma wp_fatalI [micro_rust_wp_intros]: notes asepconj_simp [simp] assumes \is_aborting_striple_context \\ - and \\r. ucincl (\ r)\ shows \\ \ \\

\ \ fatal!(msg) \ \ \ \\ using assms by (auto intro!: aentails_yonedaI simp add: sstriple_wp_iff sstriple_fatal) lemma wp_literal [micro_rust_wp_simps]: notes asepconj_simp [simp] - assumes \\r. ucincl (\ r)\ - shows \\\

\ (\v) \ \ \ = \ v\ - using assms by (auto intro!: aentails_yonedaI simp add: sstriple_wp_iff sstriple_literal) - -lemma wp_literal_coreI: - assumes \\r. ucincl (\ r)\ - and \\ \ \ v\ - shows \\ \ \\

\ (\v) \ \ \\ -using assms by (subst wp_literal) + shows \\\

\ (\v) \ \ \ = \ v\ + by (auto intro!: aentails_yonedaI simp add: sstriple_wp_iff sstriple_literal) lemma wp_literalI[micro_rust_wp_intros]: - assumes \\ \ \ v \ \\ + assumes \\ \ \ v\ shows \\ \ \\

\ (\v) \ \ \\ by (simp add: assms local.sstriple_literal local.sstriple_wp_iff) text\As immediate corollaries of the result above we have analogous results for all of our literal values for Core Micro Rust:\ corollary wp_core_rust_literals [micro_rust_wp_simps]: - shows \\\. (\r. ucincl (\ r)) \ (\s. ucincl (\ s)) \ \\

\ `True \ \ \= \ True\ - and \\\. (\r. ucincl (\ r)) \ (\s. ucincl (\ s)) \ \\

\ `False \ \ \= \ False\ - and \\\. (\r. ucincl (\ r)) \ (\s. ucincl (\ s)) \ \\

\ `None \ \ \= \ None\ - and \\x \. (\r. ucincl (\ r)) \ (\s. ucincl (\ s)) \ \\

\ (`Some (\x)) \ \ \= \ (Some x)\ + shows \\\

\ `True \ \ \= \ True\ + and \\\

\ `False \ \ \= \ False\ + and \\\. \\

\ `None \ \ \= \ None\ + and \\x \. \\

\ (`Some (\x)) \ \ \= \ (Some x)\ by (auto simp add: true_def false_def none_def some_def wp_literal micro_rust_simps) lemma wp_abort [micro_rust_wp_simps]: - shows \\\

\ (abort a) \ \ \ = \ a \ UNIV\ + shows \\\

\ (abort a) \ \ \ = \ a\ by (clarsimp intro!: aentails_yonedaI simp add: sstriple_wp_iff sstriple_abort) corollary wp_panic [micro_rust_wp_simps]: - shows \\\

\ \ panic!(m) \ \ \ \ = \ (Panic m) \ UNIV\ + shows \\\

\ \ panic!(m) \ \ \ \ = \ (Panic m)\ by (intro wp_abort) lemma wp_abortI [micro_rust_wp_intros]: - assumes \\ \ \ a \ UNIV\ + assumes \\ \ \ a\ shows \\ \ \\

\ (abort a) \ \ \\ using assms by (subst wp_abort) lemma wp_panicI [micro_rust_wp_intros]: - assumes \\ \ \ (Panic m) \ UNIV\ + assumes \\ \ \ (Panic m)\ shows \\ \ \\

\ \ panic!(m) \ \ \ \\ using assms by (subst wp_panic) lemma wp_return [micro_rust_wp_simps]: - shows \\\

\ \ return v; \ \ \ \ = \ v \ \\ + shows \\\

\ \ return v; \ \ \ \ = \ v\ by (auto intro!: aentails_yonedaI simp add: sstriple_wp_iff sstriple_return) lemma wp_returnI [micro_rust_wp_intros]: - assumes \\ \ \ v \ \\ + assumes \\ \ \ v\ shows \\ \ \\

\ \ return v; \ \ \ \\ using assms by (simp add: wp_return) lemma wp_assert [micro_rust_wp_simps]: - shows \\\

\ \ assert!(x) \ \ \ \ = (\x\ \ (UNIV \ \ ())) \ (\\x\ \ (UNIV \ \ AssertionFailed))\ - apply (intro aentails_yonedaI) - apply (clarsimp simp add: sstriple_wp_iff aentails_simp sstriple_assert apure_def asepconj_simp - bot_aentails_all) - apply (meson aentails_refl_eq aentails_trans aentails_top_R' aentails_uc' - ucincl_UNIV ucincl_asepconjL) - done + shows \\\

\ \ assert!(x) \ \ \ \ = + (\x\ \ \ ()) \ (\\x\ \ \ AssertionFailed)\ + by (intro aentails_yonedaI) + (cases x; clarsimp simp add: sstriple_wp_iff sstriple_assert aentails_simp asepconj_simp + awand_bot aentails_true) lemma wp_assert_eq [micro_rust_wp_simps]: shows \\\

\ \ assert_eq!(x, y) \ \ \ \ = - (\x=y\ \ (UNIV \ \ ())) \ (\x\y\ \ (UNIV \ \ AssertionFailed))\ + (\x=y\ \ \ ()) \ (\x\y\ \ \ AssertionFailed)\ by (clarsimp simp add: wp_assert[simplified assert_def micro_rust_simps] assert_eq_def assert_eq_val_def micro_rust_simps) -thm aentails_frulify_pure - lemma wp_assertI[micro_rust_wp_intros]: notes aentails_intro [intro] - assumes \\ \ (\x\ \ \ ())\ + assumes \\ \ \x\ \ \ ()\ shows \\ \ \\

\ \ assert!(x) \ \ \ \\ proof - - have \\x\ \ \ () \ \x\ \ UNIV \ \ ()\ - by (simp add: aentails_refl apure_entailsL' asepconj_comm asepconj_pure2) - moreover - have \\x\ \ \ () \ \\ x\ \ UNIV \ \ AssertionFailed\ - by (metis local.aentails_is_sat local.is_sat_pure local.is_sat_splitE) - ultimately show ?thesis + \\Both branches hoist the pure factor out of the left-hand side; because it owns nothing, that + costs no resource, and the failing branch is then unsatisfiable.\ + have ok: \(\x\ \ \ ()) \ \x\ \ \ ()\ + apply (simp add: asepconj_AC asepconj_simp) + apply (intro aentails_cancel_r_discardable discardable_in_apure_preciseI) + done + have fail: \(\x\ \ \ ()) \ \\ x\ \ \ AssertionFailed\ + by (simp add: asepconj_AC asepconj_simp bot_aentails_all) + from ok fail show ?thesis using aentails_trans[OF assms] - by (simp add: wp_assert aentails_intI asepconj_assoc awand_adjoint) + by (simp add: wp_assert aentails_intI awand_adjoint) qed lemma wp_assert_eqI[micro_rust_wp_intros]: notes aentails_intro[intro] - assumes \\ \ (\x=y\ \ \ ())\ + assumes \\ \ \x=y\ \ \ ()\ shows \\ \ \\

\ \ assert_eq!(x,y) \ \ \ \\ using assms by (clarsimp intro!: wp_assertI[simplified assert_def micro_rust_simps] simp add: assert_eq_def assert_eq_val_def micro_rust_simps) lemma wp_assert_neI[micro_rust_wp_intros]: notes aentails_intro[intro] - assumes \\ \ (\x\y\ \ \ ())\ + assumes \\ \ \x\y\ \ \ ()\ shows \\ \ \\

\ \ assert_ne!(x,y) \ \ \ \\ using assms by (clarsimp intro!: wp_assertI[simplified assert_def micro_rust_simps] simp add: assert_ne_def assert_ne_val_def micro_rust_simps) @@ -494,13 +490,12 @@ lemma wp_two_armed_conditionalI[micro_rust_wp_case_splits]: by (simp add: assms wp_two_armed_conditional) corollary wp_one_armed_conditional: - assumes \\s. ucincl (\ s)\ shows \\\

\ \ if x { \\t\ } \ \ \ \ = (if x then \\

\ t \ \ \ else \ ())\ -using assms by (simp add: micro_rust_wp_simps wp_two_armed_conditional) +by (simp add: micro_rust_wp_simps wp_two_armed_conditional) lemma wp_one_armed_conditionalI[micro_rust_wp_case_splits]: assumes \x \ \ \ \\

\ t \ \ \\ - and \\x \ \ \ \ () \ \\ + and \\x \ \ \ \ ()\ shows \\ \ \\

\ \ if x { \\t\ } \ \ \ \\ using assms by (simp add: wp_literalI wp_two_armed_conditional) @@ -566,12 +561,11 @@ lemma wp_result_casesI: lemma wp_get: notes asat_simp [simp] assumes \ucincl (has f v)\ - and \\x. ucincl (\ x)\ shows \has f v \ (has f v \ \ v) \ \\

\ (get f) \ \ \\ proof - - have \has f v \ (\x. (\x=v\ \ has f v) \ \ x) \ \\

\ (get f) \ \ \\ + have \has f v \ (\x. (apure (x=v) \ has f v) \ \ x) \ \\

\ (get f) \ \ \\ using assms by (auto intro!: sstriple_straightline_to_wp sstriple_getI) - moreover from assms have \has f v \ (has f v \ \ v) \ has f v \ (\x. (\x=v\ \ has f v) \ \ x)\ + moreover from assms have \has f v \ (has f v \ \ v) \ has f v \ (\x. (apure (x=v) \ has f v) \ \ x)\ by (clarsimp simp add: aentails_def elim!: awandE asepconjE) (force intro: asepconjI awandI) ultimately show ?thesis using aentails_trans by force @@ -581,7 +575,6 @@ lemma wp_put: assumes \\x. x \ has f v \ g x \ has f v'\ and \\x y. x\y \ x \ has f v \ g (x+y) = g x + y \ g x \ y\ and \ucincl (has f v)\ - and \\x. ucincl (\ x)\ shows \has f v \ (has f v' \ \ ()) \ \\

\ (put g) \ \ \\ proof - from assms have \has f v \ (\u. has f v' \ \ u) \ \\

\ (put g) \ \ \\ @@ -594,7 +587,6 @@ qed lemma wp_getI [micro_rust_wp_intros]: assumes \ucincl (has f v)\ - and \\x. ucincl (\ x)\ and \\ \ has f v \ (has f v \ \ v)\ shows \\ \ \\

\ (get f) \ \ \\ using assms by (force intro: aentails_trans' wp_get) @@ -603,7 +595,6 @@ lemma wp_putI: assumes \\x. x \ has f v \ g x \ has f v'\ and \\x y. x\y \ x \ has f v \ g (x+y) = g x + y \ g x \ y\ and \ucincl (has f v)\ - and \\x. ucincl (\ x)\ and \\ \ has f v \ (has f v' \ \ ())\ shows \\ \ \\

\ (put g) \ \ \\ using assms by - (rule aentails_trans', rule wp_put, auto) @@ -701,8 +692,7 @@ lemma wp_callI: using assms by - (intro wp_call_with_abortI, assumption, simp add: awand_bot) lemma wp_funliteral: - assumes \\r. ucincl (\ r)\ - shows \\\

\ \ \f1\\<^sub>1 (v0) \ \ \ \ = \ (f1 v0)\ + shows \\\

\ \ \f1\\<^sub>1 (v0) \ \ \ \ = \ (f1 v0)\ and \\\

\ \ \f2\\<^sub>2 (v0, v1) \ \ \ \ = \ (f2 v0 v1)\ and \\\

\ \ \f3\\<^sub>3 (v0, v1, v2) \ \ \ \ = \ (f3 v0 v1 v2)\ and \\\

\ \ \f4\\<^sub>4 (v0, v1, v2, v3) \ \ \ \ = \ (f4 v0 v1 v2 v3)\ @@ -710,50 +700,41 @@ lemma wp_funliteral: and \\\

\ \ \f6\\<^sub>6 (v0, v1, v2, v3, v4, v5) \ \ \ \ = \ (f6 v0 v1 v2 v3 v4 v5)\ and \\\

\ \ \f7\\<^sub>7 (v0, v1, v2, v3, v4, v5, v6) \ \ \ \ = \ (f7 v0 v1 v2 v3 v4 v5 v6)\ and \\\

\ \ \f8\\<^sub>8 (v0, v1, v2, v3, v4, v5, v6, v7) \ \ \ \ = \ (f8 v0 v1 v2 v3 v4 v5 v6 v7)\ - using assms by (clarsimp intro!: aentails_yonedaI simp add: sstriple_wp_iff + by (clarsimp intro!: aentails_yonedaI simp add: sstriple_wp_iff sstriple_call_funliteral asepconj_simp)+ lemma wp_range_new [micro_rust_wp_simps]: - assumes \\r. ucincl (\ r)\ - shows \\\

\ (\\b\\e\) \ \ \ = \ (make_range b e False)\ -using assms by (clarsimp simp add: range_new_def wp_funliteral) + shows \\\

\ (\\b\\e\) \ \ \ = \ (make_range b e False)\ + by (clarsimp simp add: range_new_def wp_funliteral) lemma wp_op_eq [micro_rust_wp_simps]: - assumes \\r. ucincl (\ r)\ - and \\r. ucincl (\ r)\ - shows \\\

\ \ \\a b. a=b\\<^sub>2(e,f) \ \ \ \ = \ (e = f)\ -using assms by (clarsimp simp add: wp_funliteral) + shows \\\

\ \ \\a b. a=b\\<^sub>2(e,f) \ \ \ \ = \ (e = f)\ + by (clarsimp simp add: wp_funliteral) lemma wp_op_eqs [micro_rust_wp_simps]: - assumes \\r. ucincl (\ r)\ - and \\r. ucincl (\ r)\ - shows \\\

\ \ e == f \ \ \ \ = \ (e = f)\ -using assms by (clarsimp simp add: urust_eq_def micro_rust_wp_simps micro_rust_simps) + shows \\\

\ \ e == f \ \ \ \ = \ (e = f)\ + by (clarsimp simp add: urust_eq_def micro_rust_wp_simps micro_rust_simps) lemma wp_word_add_no_wrap [micro_rust_wp_intros]: notes aentails_intro [intro] and aentails_simp [simp] and asepconj_simp [simp] fixes x y :: \'l::{len} word\ - assumes \ucincl (\ (x+y))\ shows \\unat x + unat y < 2^LENGTH('l)\ \ \ (x + y) \ \\

\ \ x + y \ \ \ \\ (is \?asm \ ?GOAL\) proof - - have \ucincl (\(unat x) + (unat y) < 2^(LENGTH('l))\)\ - by (simp add: ucincl_apure) - moreover from this have \ucincl ?asm\ - by (simp add: assms ucincl_apure ucincl_asepconj) - moreover from calculation and assms have I: \\ ; ?asm \ \ x + y \ \ (\r. \r = x + y\ \ \ (x+y)) \ \ \ \\ + have I: \\ ; ?asm \ \ x + y \ + \ (\r. \r = x + y\ \ \ (x+y)) \ \ \ \\ by (intro sstriple_frame_rule_no_return; simp add: sstriple_word_add_no_wrapI) - moreover from assms have \\ ; ?asm \ \ x + y \ \ \ \ \ \ \\ - by (intro sstriple_consequence[OF I]) auto + moreover have \\ ; ?asm \ \ x + y \ + \ \ \ \ \ \\ + by (intro sstriple_consequence[OF I]; auto intro: apure_precise_entailsL) ultimately show \?asm \ ?GOAL\ by (intro wp_is_weakest_precondition) qed lemma wp_word_add_no_wrapI [micro_rust_wp_intros]: fixes x y :: \'l::{len} word\ - assumes \ucincl (\ (x + y))\ - and \\ \ \unat x + unat y < 2^LENGTH('l)\ \ \ (x + y)\ + assumes \\ \ \unat x + unat y < 2^LENGTH('l)\ \ \ (x + y)\ shows \\ \ \\

\ \ x + y \ \ \ \\ using assms by - (rule aentails_trans', rule wp_word_add_no_wrap, auto) @@ -762,25 +743,21 @@ lemma wp_word_mul_no_wrap [micro_rust_wp_intros]: and aentails_simp [simp] and asepconj_simp [simp] fixes x y :: \'l::{len} word\ - assumes \ucincl (\ (x*y))\ shows \\unat x * unat y < 2^LENGTH('l)\ \ \ (x * y) \ \\

\ \ x * y \ \ \ \\ (is \?asm \ ?GOAL\) proof - - have \ucincl (\(unat x) * (unat y) < 2^(LENGTH('l))\)\ - by (simp add: ucincl_apure) - moreover from this have \ucincl ?asm\ - by (simp add: assms ucincl_apure ucincl_asepconj) - moreover from calculation and assms have I: \\ ; ?asm \ \ x * y \ \ (\r. \r = x * y\ \ \ (x*y)) \ \ \ \\ + have I: \\ ; ?asm \ \ x * y \ + \ (\r. \r = x * y\ \ \ (x*y)) \ \ \ \\ by (intro sstriple_frame_rule_no_return) (auto simp add: sstriple_word_mul_no_wrapI) - moreover from assms have \\ ; ?asm \ \ x * y \ \ \ \ \ \ \\ - by (intro sstriple_consequence[OF I]; auto) + moreover have \\ ; ?asm \ \ x * y \ + \ \ \ \ \ \\ + by (intro sstriple_consequence[OF I]; auto intro: apure_precise_entailsL) ultimately show \?asm \ ?GOAL\ by (intro wp_is_weakest_precondition) qed lemma wp_word_mul_no_wrapI [micro_rust_wp_intros]: fixes x y :: \'l::{len} word\ - assumes \ucincl (\ (x * y))\ - and \\ \ \unat x * unat y < 2^LENGTH('l)\ \ \ (x * y)\ + assumes \\ \ \unat x * unat y < 2^LENGTH('l)\ \ \ (x * y)\ shows \\ \ \\

\ \ x * y \ \ \ \\ using assms by - (rule aentails_trans', rule wp_word_mul_no_wrap, auto) @@ -789,25 +766,21 @@ lemma wp_word_sub_no_wrap: and aentails_simp [simp] and asepconj_simp [simp] fixes x y :: \'l::{len} word\ - assumes \ucincl (\ (x - y))\ shows \\y \ x\ \ \ (x - y) \ \\

\ \ x - y \ \ \ \\ (is \?asm \ ?GOAL\) proof - - have \ucincl (\y \ x\)\ - by (simp add: ucincl_apure) - moreover from this have \ucincl ?asm\ - by (simp add: assms ucincl_apure ucincl_asepconj) - moreover from calculation and assms have I: \\ ; ?asm \ \ x - y \ \ (\r. \r = x - y\ \ \ (x - y)) \ \ \ \\ + have I: \\ ; ?asm \ \ x - y \ + \ (\r. \r = x - y\ \ \ (x - y)) \ \ \ \\ by (intro sstriple_frame_rule_no_return) (auto simp add: sstriple_word_sub_no_wrapI) - moreover from assms have \\ ; ?asm \ \ x - y \ \ \ \ \ \ \\ - by (intro sstriple_consequence[OF I]) auto + moreover have \\ ; ?asm \ \ x - y \ + \ \ \ \ \ \\ + by (intro sstriple_consequence[OF I]) (auto intro: apure_precise_entailsL) ultimately show \?asm \ ?GOAL\ by (intro wp_is_weakest_precondition) qed lemma wp_word_sub_no_wrapI [micro_rust_wp_intros]: fixes x y :: \'l::{len} word\ - assumes \ucincl (\ (x - y))\ - and \\ \ \y \ x\ \ \ (x - y)\ + assumes \\ \ \y \ x\ \ \ (x - y)\ shows \\ \ \\

\ \ x - y \ \ \ \\ using assms by - (rule aentails_trans', rule wp_word_sub_no_wrap, auto) @@ -816,25 +789,21 @@ lemma wp_word_udiv: and aentails_simp [simp] and asepconj_simp [simp] fixes x y :: \'l::{len} word\ - assumes \ucincl (\ (x div y))\ shows \\y \ 0\ \ \ (x div y) \ \\

\ \ x / y \ \ \ \\ (is \?asm \ ?GOAL\) proof - - have \ucincl (\y \ 0\)\ - by (simp add: ucincl_apure) - moreover from this have \ucincl ?asm\ - by (simp add: assms ucincl_apure ucincl_asepconj) - moreover from calculation and assms have I: \\ ; ?asm \ \ x / y \ \ (\r. \r = x div y\ \ \ (x div y)) \ \ \ \\ + have I: \\ ; ?asm \ \ x / y \ + \ (\r. \r = x div y\ \ \ (x div y)) \ \ \ \\ by (intro sstriple_frame_rule_no_return) (auto simp add: sstriple_word_udivI) - moreover from assms have \\ ; ?asm \ \ x / y \ \ \ \ \ \ \\ - by (intro sstriple_consequence[OF I]) auto + moreover have \\ ; ?asm \ \ x / y \ + \ \ \ \ \ \\ + by (intro sstriple_consequence[OF I]) (auto intro: apure_precise_entailsL) ultimately show \?asm \ ?GOAL\ by (intro wp_is_weakest_precondition) qed lemma wp_word_udivI [micro_rust_wp_intros]: fixes x y :: \'l::{len} word\ - assumes \ucincl (\ (x div y))\ - and \\ \ \y \ 0\ \ \ (x div y)\ + assumes \\ \ \y \ 0\ \ \ (x div y)\ shows \\ \ \\

\ \ x / y \ \ \ \\ using assms by - (rule aentails_trans', rule wp_word_udiv, auto) @@ -843,69 +812,57 @@ lemma wp_word_umod: and aentails_simp [simp] and asepconj_simp [simp] fixes x y :: \'l::{len} word\ - assumes \ucincl (\ (x mod y))\ shows \\y \ 0\ \ \ (x mod y) \ \\

\ \ x % y \ \ \ \\ (is \?asm \ ?GOAL\) proof - - have \ucincl (\y \ 0\)\ - by (simp add: ucincl_apure) - moreover from this have \ucincl ?asm\ - by (simp add: assms ucincl_apure ucincl_asepconj) - moreover from calculation and assms have I: \\ ; ?asm \ \ x % y \ \ (\r. \r = x mod y\ \ \ (x mod y)) \ \ \ \\ + have I: \\ ; ?asm \ \ x % y \ + \ (\r. \r = x mod y\ \ \ (x mod y)) \ \ \ \\ by (intro sstriple_frame_rule_no_return) (auto simp add: sstriple_word_umodI) - moreover from assms have \\ ; ?asm \ \ x % y \ \ \ \ \ \ \\ - by (intro sstriple_consequence[OF I]) auto + moreover have \\ ; ?asm \ \ x % y \ + \ \ \ \ \ \\ + by (intro sstriple_consequence[OF I]) (auto intro: apure_precise_entailsL) ultimately show \?asm \ ?GOAL\ by (intro wp_is_weakest_precondition) qed lemma wp_word_umodI [micro_rust_wp_intros]: fixes x y :: \'l::{len} word\ - assumes \ucincl (\ (x mod y))\ - and \\ \ \y \ 0\ \ \ (x mod y)\ + assumes \\ \ \y \ 0\ \ \ (x mod y)\ shows \\ \ \\

\ \ x % y \ \ \ \\ using assms by - (rule aentails_trans', rule wp_word_umod, auto) lemma wp_bitwise_or: - assumes \\v. ucincl (\ v)\ - shows \\ (x OR y) \ \\

\ \ x | y \ \ \ \\ -using assms by (intro sstriple_pure_to_wp') (auto intro: sstriple_bitwise_orI) + shows \\ (x OR y) \ \\

\ \ x | y \ \ \ \\ + by (intro sstriple_pure_to_wp') (auto intro: sstriple_bitwise_orI) lemma wp_bitwise_and: - assumes \\v. ucincl (\ v)\ - shows \\ (x AND y) \ \\

\ \ x & y \ \ \ \\ -using assms by (intro sstriple_pure_to_wp') (auto intro: sstriple_bitwise_andI) + shows \\ (x AND y) \ \\

\ \ x & y \ \ \ \\ + by (intro sstriple_pure_to_wp') (auto intro: sstriple_bitwise_andI) lemma wp_bitwise_xor: - assumes \\v. ucincl (\ v)\ - shows \\ (x XOR y) \ \\

\ \ x ^ y \ \ \ \\ -using assms by (intro sstriple_pure_to_wp') (auto intro: sstriple_bitwise_xorI) + shows \\ (x XOR y) \ \\

\ \ x ^ y \ \ \ \\ + by (intro sstriple_pure_to_wp') (auto intro: sstriple_bitwise_xorI) lemma wp_bitwise_not: - assumes \\v. ucincl (\ v)\ - shows \\ (NOT x) \ \\

\ \ !x \ \ \ \\ -using assms by (intro sstriple_pure_to_wp') (auto intro: sstriple_bitwise_notI) + shows \\ (NOT x) \ \\

\ \ !x \ \ \ \\ + by (intro sstriple_pure_to_wp') (auto intro: sstriple_bitwise_notI) lemma wp_bitwise_orI [micro_rust_wp_intros]: - assumes \\v. ucincl (\ v)\ - and \\ \ \ (x OR y)\ + assumes \\ \ \ (x OR y)\ shows \\ \ \\

\ \ x | y \ \ \ \\ using assms wp_bitwise_or aentails_trans' by blast lemma wp_bitwise_andI [micro_rust_wp_intros]: - assumes \\v. ucincl (\ v)\ - and \\ \ \ (x AND y)\ + assumes \\ \ \ (x AND y)\ shows \\ \ \\

\ \ x & y \ \ \ \\ using assms wp_bitwise_and aentails_trans' by blast lemma wp_bitwise_xorI [micro_rust_wp_intros]: - assumes \\v. ucincl (\ v)\ - and \\ \ \ (x XOR y)\ + assumes \\ \ \ (x XOR y)\ shows \\ \ \\

\ \ x ^ y \ \ \ \\ using assms wp_bitwise_xor aentails_trans' by blast lemma wp_bitwise_notI [micro_rust_wp_intros]: - assumes \\v. ucincl (\ v)\ - and \\ \ \ (NOT x)\ + assumes \\ \ \ (NOT x)\ shows \\ \ \\

\ \ !x \ \ \ \\ using assms wp_bitwise_not aentails_trans' by blast @@ -915,18 +872,15 @@ lemma wp_word_shift_left: and asepconj_simp[simp] fixes x :: \'l0::{len} word\ and y :: \64 word\ - assumes \ucincl (\ (push_bit (unat y) x))\ shows \\unat y < LENGTH('l0)\ \ \ (push_bit (unat y) x) \ \\

\ \ x << y \ \ \ \\ (is \?asm \ ?GOAL\) proof - - have \ucincl (\unat y < LENGTH('l0)\)\ - by (simp add: ucincl_apure) - moreover from this have \ucincl ?asm\ - by (simp add: assms ucincl_apure ucincl_asepconj) - moreover from calculation and assms have - I: \\ ; ?asm \ \ x << y \ \ (\r. \r = push_bit (unat y) x\ \ \ (push_bit (unat y) x)) \ \ \ \\ + have I: \\ ; ?asm \ \ x << y \ + \ (\r. \r = push_bit (unat y) x\ \ \ (push_bit (unat y) x)) + \ \ \ \\ by (intro sstriple_frame_rule_no_return) (auto simp add: sstriple_word_shift_leftI) - moreover from assms have \\ ; ?asm \ \ x << y \ \ \ \ \ \ \\ - by (intro sstriple_consequence[OF I]) auto + moreover have \\ ; ?asm \ \ x << y \ + \ \ \ \ \ \\ + by (intro sstriple_consequence[OF I]) (auto intro: apure_precise_entailsL) ultimately show \?asm \ ?GOAL\ by (intro wp_is_weakest_precondition) qed @@ -934,8 +888,7 @@ qed lemma wp_word_shift_leftI [micro_rust_wp_intros]: fixes x :: \'l0::{len} word\ and y :: \64 word\ - assumes \ucincl (\ (push_bit (unat y) x))\ - and \\ \ \unat y < LENGTH('l0)\ \ \ (push_bit (unat y) x)\ + assumes \\ \ \unat y < LENGTH('l0)\ \ \ (push_bit (unat y) x)\ shows \\ \ \\

\ \ x << y \ \ \ \\ using assms wp_word_shift_left aentails_trans' by blast @@ -945,18 +898,15 @@ lemma wp_word_shift_right: and asepconj_simp [simp] fixes x :: \'l0::{len} word\ and y :: \64 word\ - assumes \ucincl (\ (drop_bit (unat y) x))\ shows \\unat y < LENGTH('l0)\ \ \ (drop_bit (unat y) x) \ \\

\ \ x >> y \ \ \ \\ (is \?asm \ ?GOAL\) proof - - have \ucincl (\unat y < LENGTH('l0)\)\ - by (simp add: ucincl_apure) - moreover from this have \ucincl ?asm\ - by (simp add: assms ucincl_apure ucincl_asepconj) - moreover from calculation and assms have - I: \\ ; ?asm \ \ x >> y \ \ (\r. \r = drop_bit (unat y) x\ \ \ (drop_bit (unat y) x)) \ \ \ \\ + have I: \\ ; ?asm \ \ x >> y \ + \ (\r. \r = drop_bit (unat y) x\ \ \ (drop_bit (unat y) x)) + \ \ \ \\ by (intro sstriple_frame_rule_no_return) (auto simp add: sstriple_word_shift_rightI) - moreover from assms have \\ ; ?asm \ \ x >> y \ \ \ \ \ \ \\ - by (intro sstriple_consequence[OF I]) auto + moreover have \\ ; ?asm \ \ x >> y \ + \ \ \ \ \ \\ + by (intro sstriple_consequence[OF I]) (auto intro: apure_precise_entailsL) ultimately show \?asm \ ?GOAL\ by (intro wp_is_weakest_precondition) qed @@ -964,13 +914,15 @@ qed lemma wp_word_shift_rightI [micro_rust_wp_intros]: fixes x :: \'l0::{len} word\ and y :: \64 word\ - assumes \ucincl (\ (drop_bit (unat y) x))\ - and \\ \ \unat y < LENGTH('l0)\ \ \ (drop_bit (unat y) x)\ + assumes \\ \ \unat y < LENGTH('l0)\ \ \ (drop_bit (unat y) x)\ shows \\ \ \\

\ \ x >> y \ \ \ \\ using assms wp_word_shift_right aentails_trans' by blast +\\Exact-accounting automation uses \<^verbatim>\apure_precise_entailsR\, whose pure +factor owns nothing, and \<^verbatim>\apure_entailsR_restricted\, whose remaining conjunct is +upwards closed.\ declare aexists_entailsL aexists_entailsR aforall_entailsL aforall_entailsR apure_entails_iff - apure_entailsR [micro_rust_wp_intros] + apure_precise_entailsR apure_entailsR_restricted [micro_rust_wp_intros] subsection\Loops\ @@ -980,18 +932,19 @@ lemma wp_raw_for_loopI: notes aentails_intro [intro] and aentails_simp [simp] and asepconj_simp [simp] - assumes \\past todo. ucincl (INV past todo)\ - and \\r. ucincl (\ r)\ - and \\ \ INV [] xs\ + assumes \\ \ INV [] xs\ and \\past cur todo. xs = past@(cur#todo) \ INV past (cur#todo) \ \\

\ (f cur) (\_. INV (past@[cur]) todo) \ \\ and \INV xs [] \ \ ()\ shows \\ \ \\

\ (raw_for_loop xs f) \ \ \\ proof - - from assms have H: \\ ; \xs = []@xs\ \ INV [] xs \ raw_for_loop xs f \ (\_. \xs = xs@[]\ \ INV xs []) \ \ \ \\ - by (intro sstriple_raw_for_loop) (force intro: ucincl_intros wp_to_sstriple) + from assms have H: \\ ; \xs = []@xs\ \ INV [] xs \ raw_for_loop xs f + \ (\_. \xs = xs@[]\ \ INV xs []) \ \ \ \\ + by (intro sstriple_raw_for_loop) + (force intro: wp_to_sstriple apure_precise_entailsL apure_precise_entailsR) from assms have \INV [] xs \ \\

\ (raw_for_loop xs f) \ \ \\ - by (intro wp_is_weakest_precondition; clarsimp intro: ucincl_intros) - (rule sstriple_consequence[OF H]; clarsimp simp add: aentails_refl) + by (intro wp_is_weakest_precondition; clarsimp) + (rule sstriple_consequence[OF H]; + clarsimp simp add: aentails_refl apure_precise_entailsL apure_precise_entailsR) from this and assms show ?thesis by blast qed @@ -999,22 +952,17 @@ qed text\The following is a framed version of \<^text>\wp_raw_for_loopI\ recovering the latter if \<^term>\\ = UNIV\.\ lemma wp_raw_for_loop_framedI: - assumes \\past todo. ucincl (INV past todo)\ - and \\r. ucincl (\ r)\ - and \ucincl (\ ())\ - and \\r. ucincl (\ r)\ - and \\ \ INV [] xs \ ((INV xs [] \ \ ()) \ (\r. \ r \ \ r) \ (\r. \ r \ \ r))\ + assumes \\ \ INV [] xs \ ((INV xs [] \ \ ()) \ (\r. \ r \ \ r) \ (\r. \ r \ \ r))\ and \\past cur todo. INV past (cur#todo) \ \\

\ (f cur) (\_. INV (past@[cur]) todo) \ \\ shows \\ \ \\

\ (raw_for_loop xs f) \ \ \\ proof - let ?pc = \((INV xs [] \ \ ()) \ (\r. \ r \ \ r) \ (\r. \ r \ \ r))\ from assms have \\ ; INV [] xs \ ?pc \ raw_for_loop xs f \ \ \ \ \ \\ - by (intro sstriple_raw_for_loop_framed) (auto simp add: local.wp_to_sstriple ucincl_intros) - from this and assms have \INV [] xs \ ?pc \ \\

\ (raw_for_loop xs f) \ \ \\ - using local.ucincl_asepconj wp_is_weakest_precondition by (metis (mono_tags, lifting) - ucincl_Int local.ucincl_IntE local.ucincl_awand local.ucincl_inter) - from this and assms show ?thesis - by (meson assms ucincl_asepconj ucincl_awand aentails_trans') + by (intro sstriple_raw_for_loop_framed) (auto simp add: local.wp_to_sstriple) + from this have X: \INV [] xs \ ?pc \ \\

\ (raw_for_loop xs f) \ \ \\ + by (rule wp_is_weakest_precondition) + show ?thesis + by (rule aentails_trans'[OF X assms(1)]) qed text\Alternative loop rule which might be easier to use in some situations. Passing the list to the @@ -1023,22 +971,17 @@ list will be named in the current proof state.\ lemma wp_raw_for_loop_framedI': fixes xs :: \'e list\ and INV :: \'e list \ nat \ 'a assert\ - assumes \\ls i. ucincl (INV ls i)\ - and \\r. ucincl (\ r)\ - and \ucincl (\ ())\ - and \\r. ucincl (\ r)\ - and \\ \ INV xs 0 \ ((INV xs (length xs) \ \ ()) \ (\r. \ r \ \ r) \ (\r. \ r \ \ r))\ + assumes \\ \ INV xs 0 \ ((INV xs (length xs) \ \ ()) \ (\r. \ r \ \ r) \ (\r. \ r \ \ r))\ and \\i. i < length xs \ INV xs i \ \\

\ (f (xs ! i)) (\_. INV xs (i+1)) \ \\ shows \\ \ \\

\ (raw_for_loop xs f) \ \ \\ proof - let ?pc = \((INV xs (length xs) \ \ ()) \ (\r. \ r \ \ r) \ (\r. \ r \ \ r))\ from assms have \\ ; INV xs 0 \ ?pc \ raw_for_loop xs f \ \ \ \ \ \\ - by (intro sstriple_raw_for_loop_framed') (auto simp add: local.wp_to_sstriple ucincl_intros) - from this and assms have \INV xs 0 \ ?pc \ \\

\ (raw_for_loop xs f) \ \ \\ - by (intro wp_is_weakest_precondition) (auto intro!: ucincl_Int ucincl_awand ucincl_inter - ucincl_asepconj) - from this and assms show ?thesis - by (meson assms ucincl_asepconj ucincl_awand aentails_trans') + by (intro sstriple_raw_for_loop_framed') (auto simp add: local.wp_to_sstriple) + from this have X: \INV xs 0 \ ?pc \ \\

\ (raw_for_loop xs f) \ \ \\ + by (rule wp_is_weakest_precondition) + show ?thesis + by (rule aentails_trans'[OF X assms(1)]) qed subsection\Bounded while loops\ @@ -1046,12 +989,7 @@ subsection\Bounded while loops\ lemma wp_bounded_while_framedI: fixes INV :: \nat \ 'a assert\ and INV' :: \nat \ 'a assert\ - assumes \\k. ucincl (INV k)\ - and \\k. ucincl (INV' k)\ - and \\r. ucincl (\ r)\ - and \ucincl (\ ())\ - and \\r. ucincl (\ r)\ - and \\ \ INV n \ ((INV 0 \ \ ()) \ (\r. \ r \ \ r) \ (\r. \ r \ \ r))\ + assumes \\ \ INV n \ ((INV 0 \ \ ()) \ (\r. \ r \ \ r) \ (\r. \ r \ \ r))\ and \\k. k < n \ INV (Suc k) \ \\

\ cond (\c. if c then INV' k else INV 0) \ \\ @@ -1062,12 +1000,11 @@ proof - let ?pc = \((INV 0 \ \ ()) \ (\r. \ r \ \ r) \ (\r. \ r \ \ r))\ from assms have \\ ; INV n \ ?pc \ bounded_while n cond body \ \ \ \ \ \\ by (intro sstriple_bounded_while_framed[where INV'=INV']) - (auto simp add: local.wp_to_sstriple ucincl_intros) - from this and assms have \INV n \ ?pc \ \\

\ (bounded_while n cond body) \ \ \\ - by (intro wp_is_weakest_precondition) (auto intro!: ucincl_Int ucincl_awand ucincl_inter - ucincl_asepconj) - from this and assms show ?thesis - by (meson assms ucincl_asepconj ucincl_awand aentails_trans') + (auto simp add: local.wp_to_sstriple) + from this have X: \INV n \ ?pc \ \\

\ (bounded_while n cond body) \ \ \\ + by (rule wp_is_weakest_precondition) + show ?thesis + by (rule aentails_trans'[OF X assms(1)]) qed subsection\Gather\ @@ -1076,34 +1013,25 @@ lemma wp_gather_framedI: fixes INV :: \nat \ 'v list \ 'a assert\ and \ :: \nat \ 'v \ bool\ and thunks :: \('a, 'v, 'r, 'abort, 'i prompt, 'o prompt_output) expression list\ - assumes \\r. ucincl (\ r)\ - and \\r. ucincl (\ r)\ - and \\r. ucincl (\ r)\ - and \\ls i. ucincl (INV i ls)\ - and \\ \ INV 0 [] \ ((\r. (INV (length thunks) r \ \ r)) \ (\r. \ r \ \ r) \ (\r. \ r \ \ r))\ + assumes \\ \ INV 0 [] \ ((\r. (INV (length thunks) r \ \ r)) \ (\r. \ r \ \ r) \ (\r. \ r \ \ r))\ and \\i res. i < length thunks \ length res = i \ \ ; INV i res \ thunks ! i \ (\v. INV (i+1) (res @ [v])) \ \ \ \\ shows \\ \ \\

\ (gather thunks) \ \ \\ proof - let ?pc = \((\r. (INV (length thunks) r \ \ r)) \ (\r. \ r \ \ r) \ (\r. \ r \ \ r))\ from assms have \\ ; INV 0 [] \ ?pc \ gather thunks \ \ \ \ \ \\ - by (intro sstriple_gather_framed; simp add: local.wp_to_sstriple ucincl_intros) - from this and assms have \INV 0 [] \ ?pc \ \\

\ (gather thunks) \ \ \\ - by (intro wp_is_weakest_precondition) (auto intro!: ucincl_asepconj ucincl_inter ucincl_Int - ucincl_awand) - from this and assms show ?thesis - by (meson assms ucincl_asepconj ucincl_awand aentails_trans') + by (intro sstriple_gather_framed; simp add: local.wp_to_sstriple) + from this have X: \INV 0 [] \ ?pc \ \\

\ (gather thunks) \ \ \\ + by (rule wp_is_weakest_precondition) + show ?thesis + by (rule aentails_trans'[OF X assms(1)]) qed lemma wp_gather_framedI': fixes INV :: \nat \ 'v list \ 'a assert\ and \ :: \nat \ 'v \ bool\ and thunks :: \('a, 'v, 'r, 'abort, 'i prompt, 'o prompt_output) expression list\ - assumes \\r. ucincl (\ r)\ - and \\r. ucincl (\ r)\ - and \\r. ucincl (\ r)\ - and \\ls i. ucincl (INV i ls)\ - and \\ \ INV 0 [] \ ((\r. (INV (length thunks) r \ \ r)) \ (\r. \ r \ \ r) \ (\r. \ r \ \ r))\ + assumes \\ \ INV 0 [] \ ((\r. (INV (length thunks) r \ \ r)) \ (\r. \ r \ \ r) \ (\r. \ r \ \ r))\ and \\i res. i < length thunks \ length res = i \ INV i res \ \\

\ (thunks ! i) (\v. INV (i+1) (res @ [v])) \ \\ shows \\ \ \\

\ (gather thunks) \ \ \\ diff --git a/tutorial/Tutorial_SLWorked.thy b/tutorial/Tutorial_SLWorked.thy index d954d882..7eda3cd7 100644 --- a/tutorial/Tutorial_SLWorked.thy +++ b/tutorial/Tutorial_SLWorked.thy @@ -183,12 +183,17 @@ definition sltriple (\\_\/ _/ \_\\) \\P\ e \Q\ \ \s x s'. \\For all states @{term s}, @{term s'} and return values @{term x} ...\ s \\e\ (x, s') \\... if @{term e} can tranform @{term s} into @{term s'}, producing @{term x} ...\ - \ (\\. ucincl \ \ \\then for any predicate @{term \} (disjoint from P)\ + \ (\\. \\then for \<^emph>\any\ predicate @{term \} (disjoint from P)\ \\if @{term s} satisfies the precondition and, disjointly, @{term \}\ s \ P \ \ \ \\then @{term s'} satisfies the postcondition and, disjointly, still @{term \}\ s' \ Q x \ \)\ +text\\<^bold>\Note\ the frame @{term \} is \<^emph>\unrestricted\. An upwards-closed frame +could absorb resources omitted by @{term \Q x\}. Quantifying over \<^emph>\all\ +frames, including those owning nothing, makes the post-condition account for +the resulting state \<^bold>\exactly\.\ + text\By definition, we obtain the \<^bold>\frame rule\, which we saw failing in the previous session:\ lemma frame_rule: @@ -197,11 +202,9 @@ lemma frame_rule: unfolding sltriple_def proof (intro allI impI) fix h x h' \ - assume step: \h \\e\ (x, h')\ and uc: \ucincl \\ - and pre: \h \ (P \ S) \ \\ + assume step: \h \\e\ (x, h')\ and pre: \h \ (P \ S) \ \\ have \h \ P \ (S \ \)\ using pre by (simp add: asepconj_assoc) - moreover have \ucincl (S \ \)\ using uc by (rule ucincl_asepconjR) - ultimately have \h' \ Q x \ (S \ \)\ + hence \h' \ Q x \ (S \ \)\ using assms step by (force simp: sltriple_def) thus \h' \ (\x. Q x \ S) x \ \\ by (simp add: asepconj_assoc) @@ -218,23 +221,38 @@ text \\P \ UNIV\ holds on a heap that has \<^emph>\@{thm [display, show_question_marks=false] ucincl_alt}\ -text \The main practical relevance of \ucincl\ is that we can \<^bold>\hoist - pure assertions\ out of an entailment, on either side:\ +text \Absorbing resource is the same thing as \<^bold>\forgetting\ it, so \ucincl\ is + what licenses \<^emph>\dropping\ a conjunct. AutoCorrode names that licence in + general, as a relation between what is thrown away and what is kept:\ text \ -\<^item> @{thm [show_question_marks=false] apure_entails_iff} -\<^item> @{thm [show_question_marks=false] apure_entailsR}\ +\<^item> @{thm [show_question_marks=false] discardable_in_def} +\<^item> @{thm [show_question_marks=false] aentails_cancel_l_discardable} +\<^item> @{thm [show_question_marks=false] discardable_in_univ_iff_ucincl}\ + +text \The last line is the point: \ucincl \\ says exactly ``\<^emph>\anything at all\ + may be discarded into \\\''. Upwards closure is the extreme case of disposal, + and disposal is the role \ucincl\ plays. At the other extreme, discarding + \<^emph>\nothing\ asks nothing of \\\ -- which is why a pure side-condition is best + carried by \\P\\, owning nothing, and is then hoisted with no side-condition + at all:\ + +text \ +\<^item> @{thm [show_question_marks=false] apure_precise_entailsL} \\Hoist out of the LHS\ +\<^item> @{thm [show_question_marks=false] apure_precise_entailsR} \\\is_sat \\: some state satisfies \\\\\ text \AutoCorrode tracks \ucincl\ via a named-theorems bundle - \ucincl_intros\; the \ucincl_solve\ tactic discharges such side-conditions - automatically.\ + \ucincl_intros\; the \ucincl_solve\ tactic discharges most such side-conditions + automatically. \<^bold>\Not all\: a weakest precondition is upwards closed only when + all three of its post-conditions are, so there \ucincl_solve\ needs those + supplied to it.\ end_slide slide \Common operations on entailments\ text \Working with \\\ and \\\ feels similar to working in Pure logic, with \<^term>\(\)\ corresponding to \<^term>\(\)\ and \<^term>\(\)\ -corresponding \<^term>\(\)\; \<^emph>\except\ that assertions are \<^bold>\resourceful\ and cannot be duplicated (but they can be dropped under \<^term>\ucincl\!).\ +corresponding \<^term>\(\)\; \<^emph>\except\ that assertions are \<^bold>\resourceful\ and cannot be duplicated (but they can be dropped where \<^const>\discardable_in\ licenses it, \ucincl\ being the extreme case!).\ text \\<^bold>\Cancellation\ (drop a shared conjunct on LHS and RHS):\ text \ @@ -301,15 +319,14 @@ next show \\P\ e \Q\\ unfolding sltriple_def proof (intro allI impI) fix h x h' \ - assume st: \h \\e\ (x, h')\ and uc: \ucincl \\ - and pre: \h \ P \ \\ + assume st: \h \\e\ (x, h')\ and pre: \h \ P \ \\ from pre obtain t u where \h = t + u\ \t \ u\ \t \ P\ \u \ \\ by (auto simp: asepconj_def asat_def) moreover from \t \ P\ H obtain P' where \\P'\ e \Q\\ \t \ P'\ by (auto simp: aentails_def wp_sl_def asat_def) ultimately have \h \ P' \ \\ by (auto simp: asepconj_def asat_def) - with \\P'\ e \Q\\ st uc show \h' \ Q x \ \\ + with \\P'\ e \Q\\ st show \h' \ Q x \ \\ by (force simp: sltriple_def) qed qed @@ -455,6 +472,8 @@ text \Each operation gets a contract that mentions \<^emph>\only\ (*<*) +\\Points-to leaves the rest of the toy heap unconstrained. Registering its +upwards closure supports extensions to the worked example.\ lemma ucincl_pto[ucincl_intros]: \ucincl (f \ v)\ unfolding pto_def ucincl_def ucpred_def derived_order_def by (clarsimp simp: plus_fun_def plus_option_def disjoint_fun_def disjoint_option_def @@ -464,8 +483,7 @@ lemma get_x_triple: \\FX \ v\ get_x \\ - assume step: \h \\get_x\ (x, h')\ and uc: \ucincl \\ - and pre: \h \ FX \ v \ \\ + assume step: \h \\get_x\ (x, h')\ and pre: \h \ FX \ v \ \\ from step have h_eq: \h' = h\ and x_eq: \x = the (h FX)\ by (auto simp: evals_def get_x_def) from pre obtain t u where \h = t + u\ \t \ u\ \t FX = Some v\ \u \ \\ @@ -473,19 +491,17 @@ proof (intro allI impI) hence \h FX = Some v\ by (auto simp: plus_fun_def plus_option_def disjoint_fun_def disjoint_option_def split: option.splits) - hence pure_eq: \\x = v\ = (UNIV :: twoint_sl assert)\ - using x_eq by (simp add: apure_def) - have \ucincl ((FX \ v) :: twoint_sl assert)\ by (rule ucincl_pto) - thus \h' \ (\x = v\ \ FX \ v) \ \\ - using pre h_eq pure_eq by (simp add: asepconj_simp asepconj_assoc) + hence pure_eq: \\x = v\ = (emp :: twoint_sl assert)\ + using x_eq by (simp add: apure_precise_def emp_def) + show \h' \ (\x = v\ \ FX \ v) \ \\ + using pre h_eq pure_eq by (simp add: asepconj_emp_unit) qed lemma put_x_triple: \\FX \ u\ put_x v \\_. FX \ v\\ unfolding sltriple_def proof (intro allI impI) fix h x h' \ - assume step: \h \\put_x v\ (x, h')\ and uc: \ucincl \\ - and pre: \h \ FX \ u \ \\ + assume step: \h \\put_x v\ (x, h')\ and pre: \h \ FX \ u \ \\ from step have h'_eq: \h' = h(FX \ v)\ by (auto simp: evals_def put_x_def) from pre obtain t r where split: \h = t + r\ and disj: \t \ r\ @@ -511,8 +527,7 @@ lemma get_y_triple: \\FY \ v\ get_y \\ - assume step: \h \\get_y\ (x, h')\ and uc: \ucincl \\ - and pre: \h \ FY \ v \ \\ + assume step: \h \\get_y\ (x, h')\ and pre: \h \ FY \ v \ \\ from step have h_eq: \h' = h\ and x_eq: \x = the (h FY)\ by (auto simp: evals_def get_y_def) from pre obtain t u where \h = t + u\ \t \ u\ \t FY = Some v\ \u \ \\ @@ -520,19 +535,17 @@ proof (intro allI impI) hence \h FY = Some v\ by (auto simp: plus_fun_def plus_option_def disjoint_fun_def disjoint_option_def split: option.splits) - hence pure_eq: \\x = v\ = (UNIV :: twoint_sl assert)\ - using x_eq by (simp add: apure_def) - have \ucincl ((FY \ v) :: twoint_sl assert)\ by (rule ucincl_pto) - thus \h' \ (\x = v\ \ FY \ v) \ \\ - using pre h_eq pure_eq by (simp add: asepconj_simp asepconj_assoc) + hence pure_eq: \\x = v\ = (emp :: twoint_sl assert)\ + using x_eq by (simp add: apure_precise_def emp_def) + show \h' \ (\x = v\ \ FY \ v) \ \\ + using pre h_eq pure_eq by (simp add: asepconj_emp_unit) qed lemma put_y_triple: \\FY \ u\ put_y v \\_. FY \ v\\ unfolding sltriple_def proof (intro allI impI) fix h x h' \ - assume step: \h \\put_y v\ (x, h')\ and uc: \ucincl \\ - and pre: \h \ FY \ u \ \\ + assume step: \h \\put_y v\ (x, h')\ and pre: \h \ FY \ u \ \\ from step have h'_eq: \h' = h(FY \ v)\ by (auto simp: evals_def put_y_def) from pre obtain t r where split: \h = t + r\ and disj: \t \ r\ @@ -595,25 +608,19 @@ lemma %visible foo_spec: \\FX \ v\ foo \\< apply (rule wp_sl_bindI) apply (rule get_x_wp[where v=v]) apply (rule asepconj_mono5) - apply (rule ucincl_pto) apply (rule aentails_intro(10)) apply (subst awand_adjoint) - apply (subst asepconj_swap_top) - apply (rule apure_entailsL) + apply (simp only: asepconj_emp_unit) + apply (rule apure_precise_entailsL) \\...\ (*<*) - subgoal by (auto intro: ucincl_intros) apply simp - apply (subst asepconj_comm) - apply (subst asepconj_ident2) - apply (rule ucincl_pto) apply (rule put_x_wp[where u=v]) apply (rule asepconj_mono5) - apply (rule ucincl_pto) apply (rule aentails_intro(10)) apply (subst awand_adjoint) - apply (rule aentails_cancel_l) - apply (rule ucincl_pto) + apply (simp only: asepconj_emp_unit) + apply (rule aentails_refl) done (*>*) diff --git a/tutorial/Tutorial_UrustPeek_WP.thy b/tutorial/Tutorial_UrustPeek_WP.thy index d7a5976e..6780b12d 100644 --- a/tutorial/Tutorial_UrustPeek_WP.thy +++ b/tutorial/Tutorial_UrustPeek_WP.thy @@ -4,43 +4,27 @@ theory Tutorial_UrustPeek_WP Shallow_Separation_Logic.Weakest_Precondition begin -(*<*) -\\We want to drop the \<^term>\ucincl\ premises from the theorems below to avoid visual clutter -that we don't want to explain at this point. Register a custom term-printing binding to drop the -first premise of term.\ - setup \ - let - fun is_ucincl_prem t = - (case t of - \<^Const_>\Trueprop\ $ (\<^Const_>\Separation_Algebra.sepalg.ucincl _\ $ _ $ _ $ _) => true - | _ => false); - - fun drop_ucincl _ t = - Logic.list_implies - (filter_out is_ucincl_prem (Logic.strip_imp_prems t), - Logic.strip_imp_concl t); - in - Term_Style.setup \<^binding>\drop_ucincl\ (Scan.succeed drop_ucincl) - end - \ - -context sepalg begin (*>*) +(*<*) context sepalg begin (*>*) text \AutoCorrode + uRust heavily rely on a WP calculus along the above lines. Some examples:\ text \\<^bold>\Early return\ delivers to the \<^emph>\early-return\ post \\\: @{thm [source] Weakest_Precondition.wp_returnI}\ -text \@{thm [display, show_question_marks=false] (drop_ucincl) wp_returnI}\ +text \@{thm [display, show_question_marks=false] wp_returnI}\ text \\<^bold>\Panic\ delivers to the \<^emph>\abort\ post \\\: @{thm [source] Weakest_Precondition.wp_panicI}\ -text \@{thm [display, show_question_marks=false] (drop_ucincl) wp_panicI}\ +text \@{thm [display, show_question_marks=false] wp_panicI}\ text \Recall: uRust's \<^emph>\three\ postconditions \\\ / \\\ / \\\ separate value/return/abort.\ text \\<^bold>\Word addition\ -- arithmetic operators get WP rules, with appropriate constraints:\ -text \@{thm [display, show_question_marks=false] (drop_ucincl) wp_word_add_no_wrap}\ +text \@{thm [display, show_question_marks=false] wp_word_add_no_wrap}\ + +text \The constraint that rules out wrap-around appears as a factor \\_\\ of the + precondition: a \<^emph>\pure\ assertion, recording a fact about the values and owning + none of the machine state. \\\ and \\_\\ are the subject of the second half.\ text \The full set lives in \Weakest_Precondition.thy\ (literals, conditionals, calls, assert, yield, ...).\ From 9dc4b70e61e16359d06294e6e9a54ef9540501c2 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Tue, 29 Sep 2026 10:01:30 +0000 Subject: [PATCH 37/46] Crush: Add a guarded order branch MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Crush leaves order and linear-arithmetic side conditions such as `n ≤ 6 ⟹ 0 < n ⟹ n - Suc 0 < 6` to its late clarsimp branches. Those run the simplifier on the whole goal, every premise included, and a Crush goal typically carries many premises unrelated to the bound. Add an `order` branch between `safe_tac` and `clarsimp_filtered`. It runs only when the conclusion or a top-level premise is `False` or a possibly negated `<` or `<=`; premises such as `∀i --- Crush/Examples.thy | 44 +++++++++++++++++++++++++++++++++++++ Crush/crush.ML | 55 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 99 insertions(+) diff --git a/Crush/Examples.thy b/Crush/Examples.thy index a67cabb6..d06f61ef 100644 --- a/Crush/Examples.thy +++ b/Crush/Examples.thy @@ -40,6 +40,50 @@ lemma \\t x y z. P x z\ (* \x z. P x z *) oops +subsubsection\Order fallback\ + +lemma crush_base_order: + assumes \(a :: 64 word) \ b\ + and \b < a\ + shows False + using assms by crush_base + +lemma crush_base_order_premises: + assumes \\ (s :: nat) < e\ + and \\ e \ s\ + shows \P s e\ + using assms by crush_base + +lemma crush_base_order_disequality: + assumes \(a :: 16 word) \ b\ + and \\ a < b\ + shows \b < a\ + using assms by crush_base + +lemma crush_base_order_arith: + assumes \(n :: nat) \ 6\ + and \0 < n\ + shows \n - Suc 0 < 6\ + using assms by crush_base + +ML_val \ + fun assert_order_rejects name prop = + let + val goal = Goal.init (Thm.cterm_of \<^context> prop) + in + (case Seq.pull (Crush.crush_branch_order_tac \<^context> 1 goal) of + NONE => () + | SOME _ => error ("order tactic accepted " ^ quote name)) + end + + val _ = assert_order_rejects "unrelated assumption" + \<^prop>\True \ True\ + val _ = assert_order_rejects "reflexive equality" + \<^prop>\(x :: nat) = x\ + val _ = assert_order_rejects "bound only under a quantifier" + \<^prop>\\i<(n :: nat). P i \ P 0\ +\ + subsection\Separation logic\ subsubsection\Normalizing associativity of separating conjunctions\ diff --git a/Crush/crush.ML b/Crush/crush.ML index 44db43c4..bc9bd786 100644 --- a/Crush/crush.ML +++ b/Crush/crush.ML @@ -94,6 +94,7 @@ sig val crush_branch_urust_simps_tac : Proof.context -> int -> tactic val crush_branch_misc_tac : Proof.context -> int -> tactic val crush_branch_ucincl_tac : Proof.context -> int -> tactic + val crush_branch_order_tac : Proof.context -> int -> tactic val crush_branch_additional_tactic : Proof.context -> int -> tactic val crush_branch_additional_method : Proof.context -> int -> tactic val crush_branch_safe_tac : Proof.context -> int -> tactic @@ -387,6 +388,59 @@ struct else K no_tac + fun is_order_relation (Const (@{const_name less}, _) $ _ $ _) = true + | is_order_relation (Const (@{const_name less_eq}, _) $ _ $ _) = true + | is_order_relation _ = false + + fun is_order_literal (Const (@{const_name Not}, _) $ t) = is_order_relation t + | is_order_literal t = is_order_relation t + + fun is_order_prem (Const (@{const_name Trueprop}, _) $ t) = is_order_literal t + | is_order_prem _ = false + + fun is_disequality (Const (@{const_name Not}, _) $ + (Const (@{const_name HOL.eq}, Type (_, [T, _])) $ _ $ _)) = T <> @{typ bool} + | is_disequality _ = false + + fun is_order_fact (Const (@{const_name Trueprop}, _) $ t) = + is_order_literal t orelse is_disequality t + | is_order_fact _ = false + + fun is_order_concl + (Const (@{const_name Trueprop}, _) $ Const (@{const_name False}, _)) = true + | is_order_concl t = is_order_prem t + + (* Close order and linear-arithmetic side conditions such as + `n \ 6 \ 0 < n \ n - Suc 0 < 6`, or refute contradictory + bounds such as `a < b \ b \ a \ P`. The goal qualifies if its + conclusion or some top-level premise is a possibly negated `<` or + `\`. The order and arithmetic tactics then see only such + premises and disequalities `a \ b`, as needed for + `a \ b \ \ a < b \ b < a`. Crush goals carry many + unrelated premises, and searching all of them made most failed + attempts expensive. Unlike HOL's simpset solvers, this never + instantiates schematics by `refl`. *) + val crush_branch_order_tac: Proof.context -> int -> tactic = fn ctxt => + let + fun core ctxt' prems = + HOL_Order_Tac.tac prems ctxt' 1 + ORELSE (Method.insert_tac ctxt' prems 1 THEN Lin_Arith.simple_tac ctxt' 1) + fun focused concl_is_order {context = ctxt', prems, ...} = + let val prems' = filter (is_order_fact o Thm.prop_of) prems in + (if concl_is_order then all_tac else resolve_tac ctxt' @{thms FalseE} 1) + THEN core ctxt' prems' + end + in + SUBGOAL (fn (t, i) => + let + val concl_is_order = is_order_concl (Logic.strip_assums_concl t) + in + if concl_is_order orelse exists is_order_prem (Logic.strip_assums_hyp t) + then SOLVED' (Subgoal.FOCUS (focused concl_is_order) ctxt) i + else no_tac + end) + end + val update_guards_tac = Crush_Guards.update_guards_shallow_tac val crush_branch_reduced_clarsimp_tac : Proof.context -> int -> tactic = @@ -599,6 +653,7 @@ struct ("additional_method" , \<^here>, (fn _ => crush_branch_additional_method ctxt)), ("wp_case_split_tac" , \<^here>, (fn _ => crush_branch_wp_case_split_tac ctxt)), ("safe_tac" , \<^here>, (fn _ => crush_branch_safe_tac ctxt)), + ("order" , \<^here>, (fn _ => crush_branch_order_tac ctxt)), ("clarsimp_filtered" , \<^here>, (fn _ => crush_branch_filtered_clarsimp_tac ctxt)), ("clarsimp_fallback" , \<^here>, (fn _ => crush_branch_clarsimp_fallback_tac ctxt)) ] |> From 1ce1952073f5683c5b7c6fdfa0fad7e802b5da93 Mon Sep 17 00:00:00 2001 From: Ike Mulder Date: Wed, 30 Sep 2026 12:13:35 +0000 Subject: [PATCH 38/46] Make precise pure assertions canonical MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Migrate client contracts and proofs from the absorbing `apure` to resource-precise pure assertions. Use `emp` for exact triples and make residual ownership explicit where a contract deliberately forgets it. Define `apure` as the compatibility abbreviation `UNIV ⋆ ⟨P⟩` and remove its duplicate lemmas and automation. Pure reasoning now follows the precise assertion path throughout the logic and its clients. Preserve Crush scheduling: spatial drules run before a generated pure entailment becomes a HOL goal. Keep that obligation opaque until the late introduction phase, and retain the former falsehood behavior through the existing hoisting and simplification paths. Adapt dependent proofs to the unified automation. Signed-off-by: Hanno Becker --- Crush/Examples.thy | 93 +++-- Crush/Separation_Logic_Tactics.thy | 12 +- Crush/crush.ML | 3 +- Crush/seplog.ML | 67 +--- Micro_Rust_Examples/Crush_Examples.thy | 70 ++-- Micro_Rust_Examples/Linked_List.thy | 6 +- Micro_Rust_Examples/MLKEM_NTT.thy | 12 +- Micro_Rust_Examples/MLKEM_Polynomial.thy | 8 +- Micro_Rust_Examples/Showcase.thy | 16 +- Micro_Rust_Examples/Tutorial.thy | 86 ++--- Micro_Rust_Interfaces/Global_Perm_Store.thy | 14 +- .../Raw_Physical_Memory_References.thy | 10 +- Micro_Rust_Runtime/Atomic_Resource.thy | 6 +- .../Raw_Physical_Memory_Trie.thy | 35 +- Micro_Rust_Runtime/Shareable_Resource.thy | 16 +- Separation_Lenses/SLens_Pullback.thy | 13 +- Shallow_Separation_Logic/Adequacy.thy | 11 +- .../Assertion_Language.thy | 336 +++--------------- Shallow_Separation_Logic/Assertion_Triple.thy | 44 --- Shallow_Separation_Logic/Locality.thy | 4 - Shallow_Separation_Logic/Triple.thy | 46 +-- Shallow_Separation_Logic/Weak_Triple.thy | 74 ++-- .../Weakest_Precondition.thy | 13 +- tutorial/Tutorial_SLWorked.thy | 2 +- 24 files changed, 332 insertions(+), 665 deletions(-) diff --git a/Crush/Examples.thy b/Crush/Examples.thy index d06f61ef..3ca2c84a 100644 --- a/Crush/Examples.thy +++ b/Crush/Examples.thy @@ -196,7 +196,7 @@ subsubsection\Floating assumptions/conclusions\ text\There is tactic support for floating pure assumptions and conclusions:\ -schematic_goal \\ \ \ \ ?\ r \ apure (\) \ \ \ apure (\) \ apure (\ r) \ \\ +schematic_goal \\ \ \ \ ?\ r \ \\\ \ \ \ \\\ \ \\ r\ \ \\ apply (asepconj_rotate_assms) apply (aentails_float_pure_concls) apply (aentails_float_pure_assms) @@ -205,16 +205,16 @@ schematic_goal \\ \ \ \ ?\ r \ apure notepad begin fix \ \' \ :: \'s::sepalg assert\ and P Q R :: \bool\ - have \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (P) \ apure (Q) \ \ \ \' \ apure (R)\ + have \\ \ \P\ \ \' \ \Q\ \ \R\ \ \P\ \ \Q\ \ \ \ \' \ \R\\ by (aentails_float_pure_assms, aentails_float_pure_concls, rule aentails_refl) next fix \ \' \ :: \'s::sepalg assert\ and P Q R :: \bool\ - have \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (P) \ apure (Q) \ \ \ \' \ apure (R)\ + have \\ \ \P\ \ \' \ \Q\ \ \R\ \ \P\ \ \Q\ \ \ \ \' \ \R\\ \\Float assumptions and conclusions at the same time\ by (aentails_float_pure, rule aentails_refl) next fix \ \' \ :: \'s::sepalg assert\ and P Q R :: \bool\ - have \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (P) \ apure (Q) \ \ \ \' \ apure (R)\ + have \\ \ \P\ \ \' \ \Q\ \ \R\ \ \P\ \ \Q\ \ \ \ \' \ \R\\ by (aentails_float_pure, rule aentails_refl) end @@ -320,7 +320,7 @@ traversed using backtracking.\ notepad begin fix \ \' \ :: \'s::sepalg assert\ and P Q R :: \bool\ - have \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (P) \ apure (Q) \ \ \ \' \ apure (R)\ + have \\ \ \P\ \ \' \ \Q\ \ \R\ \ \P\ \ \Q\ \ \ \ \' \ \R\\ apply aentails_float_pure_assms' \\Happens to float \<^verbatim>\R\, but other options are available through backtracking\ back back @@ -334,7 +334,7 @@ next a pure assumption to the front, but only one allows the subsequent application of the introduction rule \<^verbatim>\asepconj_mono\:\ fix \ \' \ :: \'s::sepalg assert\ and P Q R :: \bool\ - have \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (Q) \ apure (P) \ \ \ \' \ apure (R)\ + have \\ \ \P\ \ \' \ \Q\ \ \R\ \ \Q\ \ \P\ \ \ \ \' \ \R\\ \\Backtracking forces floating of \<^verbatim>\Q\, which is not the first choice as we have seen above.\ apply (aentails_float_pure_assms'; intro asepconj_mono) apply aentails_float_pure_assms @@ -361,33 +361,23 @@ begin fix \ \' \ :: \'s::sepalg assert\ and P Q R :: \bool\ assume \ucincl \\ - and 1: \\ \ \' \ apure (P) \ apure (Q) \ \ \ \' \ apure (R)\ - from this have \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (P) \ apure (Q) \ \ \ \' \ apure (R)\ + and 1: \\ \ \' \ \P\ \ \Q\ \ \ \ \' \ \R\\ + from this have \\ \ \P\ \ \' \ \Q\ \ \R\ \ \P\ \ \Q\ \ \ \ \' \ \R\\ apply aentails_hoist_pure_assms apply (rule 1) done next fix \ \' \ :: \'s::sepalg assert\ and P Q R :: \bool\ - assume \ucincl \\ - and 1: \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (P)\ - and 2: \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (Q)\ - and 2: \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (R)\ - and \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ \ \ \'\ - from this have \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (P) \ apure (Q) \ \ \ \' \ apure (R)\ + assume \P\ and \Q\ and \R\ + and spatial: \\ \ \P\ \ \' \ \Q\ \ + \R\ \ \ \ \'\ + from this have \\ \ \P\ \ \' \ \Q\ \ \R\ \ \P\ \ \Q\ \ \ \ \' \ \R\\ apply aentails_hoist_pure_concls - apply auto + apply crush_base done end -text\Ordinary pure-conclusion hoisting declines when the retained -assertion has no closure licence.\ -lemma - fixes \ \ :: \'s::sepalg assert\ and P :: bool - shows \\ \ apure (P) \ \\ - apply (fails \aentails_hoist_pure_concls\) - oops - text\Precise pure assumptions own zero, so their hoist needs no closure premise and leaves no residual resource. \<^verbatim>\crush_boot\ applies this method to exact contract preconditions.\ @@ -398,7 +388,7 @@ begin and P Q :: \bool\ assume 1: \P \ Q \ \ \ \' \ \\ have \\ \ \P\ \ \' \ \Q\ \ \\ - apply aentails_hoist_pure_precise_assms + apply aentails_hoist_pure_assms apply (rule 1; assumption) done end @@ -918,29 +908,17 @@ subsubsection\Entailment simplification\ text\\<^verbatim>\aentails_simp_core\ attempts a single simplification step for a separating entailment. It is rarely used on its own but as part of more complex tactics repeating, such as -\<^verbatim>\aentails_simp_basic\:\ +\<^verbatim>\aentails_simp_basic\. Precise-pure conclusions become opaque scheduling +obligations which full Crush discharges through its late pure-introduction branch:\ notepad begin fix \ \' \ :: \'s::sepalg assert\ and P Q R :: \bool\ assume \ucincl \\ - from this have \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (P) \ apure (Q) \ \ \ \' \ apure (R)\ - apply aentails_simp_core \\Hoisting pure assumptions\ - apply aentails_simp_core \\Splitting pure conclusions\ - apply aentails_simp_core - apply aentails_simp_core - apply aentails_simp_core - apply aentails_simp_core - apply aentails_simp_core - apply aentails_simp_core - apply aentails_simp_core + from this have \\ \ \P\ \ \' \ \Q\ \ \R\ \ \P\ \ \Q\ \ \ \ \' \ \R\\ + apply aentails_simp_basic + apply crush_base done -next - fix \ \' \ :: \'s::sepalg assert\ and P Q R :: \bool\ - assume \ucincl \\ - from this have \\ \ apure (P) \ \' \ apure (Q) \ apure (R) \ apure (P) \ apure (Q) \ \ \ \' \ apure (R)\ - \\The same again, but now in one step\ - by aentails_simp_basic end text\The method \<^verbatim>\aentails_simp_basic\ combines entailment simplification with entailment @@ -954,25 +932,27 @@ notepad begin fix \ \ \ :: \'s::sepalg assert\ and P Q R :: \bool\ assume \ucincl \\ - from this have \P \ \ \ apure (Q) \ \ \ apure (R) \ \ \ \ \ apure (P) \ apure (Q) \ \ \ \ \ apure (R)\ - by aentails_simp_basic + from this have \P \ \ \ \Q\ \ \ \ \R\ \ \ \ \ \ \P\ \ \Q\ \ \ \ \ \ \R\\ + apply aentails_simp_basic + apply crush_base + done next - \\Note, however, that classical simplification is not performed:\ + \\The late Crush branch also discharges compound pure obligations after the spatial + simplifier has finished:\ fix \ \ \ :: \'s::sepalg assert\ and P Q R :: \bool\ assume \ucincl \\ - from this have \P \ \ \ apure (Q) \ \ \ apure (R) \ \ \ \ \ apure (P \ Q) \ \ \ \ \ apure (R)\ - apply aentails_simp_basic - apply simp + from this have \P \ \ \ \Q\ \ \ \ \R\ \ \ \ \ \ \P \ Q\ \ \ \ \ \ \R\\ apply aentails_simp_basic + apply crush_base done end subsubsection\Precise pure assertions\ text\The precise-pure hoists need no closure premise. On the conclusion -side they leave a separating entailment against \<^term>\apure (P)\, allowing later -spatial branches to continue. These examples exercise both directions through -the public core method.\ +side they leave the Boolean obligation as a spatial entailment, allowing later +spatial branches to establish it. These examples exercise both directions +through the public core method.\ notepad begin @@ -985,8 +965,17 @@ next assume \P\ have \\ \ \ \ \P\ \ \ \ \\ apply aentails_simp_core - apply (rule apure_entailsR0[OF \P\]) - by (rule aentails_refl) + apply (crush_base simp add: \P\) + done +next + fix \ \ \ :: \'s::sepalg assert\ + have \\ \ \False\ \ \ \ \\ + by crush_base +next + fix P :: bool + assume \is_sat (\False\ :: 's::sepalg assert)\ + then have P + by crush_base end subsubsection\Spatial \<^verbatim>\rule\\ diff --git a/Crush/Separation_Logic_Tactics.thy b/Crush/Separation_Logic_Tactics.thy index e9a1dc39..e497b366 100644 --- a/Crush/Separation_Logic_Tactics.thy +++ b/Crush/Separation_Logic_Tactics.thy @@ -433,8 +433,8 @@ method aentails_cancel_points_to_raw_with_typed = guard \K Separation_Logi (rule refl | simp)?) \ -\\Ordinary pure conclusions can be split only when the retained -conclusion absorbs the separated resource.\ +\\Split a zero-owning pure conclusion from the retained spatial +conclusion.\ method_setup aentails_hoist_pure_concls = \ Scan.succeed (SIMPLE_METHOD' o Separation_Logic_Tactics.aentails_hoist_pure_concls_tac) @@ -462,15 +462,12 @@ method contract uses f contract = subst wp_sstriple_iff, ( simp (no_asm) only: contract )? ) -\\Run the ordinary hoist first so it can consolidate its factors, then -hoist precise-pure factors. Both are optional, allowing mixed contract -preconditions.\ +\\Hoist precise-pure factors from contract preconditions.\ method crush_boot uses f contract simp = (contract f:f contract:contract, micro_rust_ssa_wp_normalize, (clarsimp simp add: Let_def simp)?, - aentails_hoist_pure_assms?, - aentails_hoist_pure_precise_assms?) + aentails_hoist_pure_assms?) section\\<^verbatim>\crush\\ @@ -482,7 +479,6 @@ declare asepconj_multi_split' [crush_asepconj_simp] declare asepconj_Inf_distrib [crush_asepconj_simp] declare asepconj_Inf_distrib2 [crush_asepconj_simp] declare asepconj_UNIV_idempotent[crush_asepconj_simp] -declare awand_pure_false [crush_asepconj_simp] declare asepconj_emp_unit [crush_asepconj_simp] \\Do not normalize precise falsehood here: the core hoist turns that factor directly into a \<^term>\False\ premise, while \<^term>\\ \ \\ would stall the loop.\ diff --git a/Crush/crush.ML b/Crush/crush.ML index bc9bd786..2f638d97 100644 --- a/Crush/crush.ML +++ b/Crush/crush.ML @@ -556,8 +556,7 @@ struct end val crush_branch_intro_pure_aentails_tac : Proof.context -> int -> tactic = fn ctxt => - Separation_Logic_Tactics.ucincl_discharge_tac ctxt - (intro_tac @{thms apure_entailsR0 apure_precise_entailsR0} ctxt) + intro_tac @{thms apure_precise_entailsR0 apure_crush_obligation_entailsR0} ctxt val crush_branch_aentails_cond_crule_tac = fn ctxt => Separation_Logic_Tactics.aentails_cond_crule_tac (Named_Theorems.get ctxt @{named_theorems crush_aentails_cond_crules}) ctxt diff --git a/Crush/seplog.ML b/Crush/seplog.ML index f3156eae..5db82eca 100644 --- a/Crush/seplog.ML +++ b/Crush/seplog.ML @@ -378,10 +378,6 @@ sig val aentails_float_pure_concls_tac' : Proof.context -> int -> tactic \ \Moves pure assumptions and conclusions in a separating entailment to the left most position(s)\ val aentails_float_pure_tac : Proof.context -> int -> tactic - \ \Moves precise pure assumptions in a separating entailment to the leftmost position(s)\ - val aentails_float_pure_precise_assms_tac : Proof.context -> int -> tactic - \ \Moves precise pure conclusions in a separating entailment to the leftmost position(s)\ - val aentails_float_pure_precise_concls_tac : Proof.context -> int -> tactic \ \Moves typed points_to assumptions in a separating entailment to the leftmost position(s)\ val aentails_float_points_to_assms_tac : Proof.context -> int -> tactic \ \Moves typed points_to assumptions in a separating entailment to the leftmost position(s); @@ -415,10 +411,6 @@ sig val aentails_hoist_pure_assms_tac : Proof.context -> int -> tactic val aentails_hoist_pure_concls_tac : Proof.context -> int -> tactic - \\Hoist zero-owning pure assumptions without a closure condition.\ - val aentails_hoist_pure_precise_assms_tac : Proof.context -> int -> tactic - \\Split zero-owning pure conclusions without a closure condition.\ - val aentails_hoist_pure_precise_concls_tac : Proof.context -> int -> tactic \\Hoist \(range ...) out of the LHS of an entailment, then intro \<^verbatim>\aexists_entailsL\.\ val aentails_hoist_existential_assms_tac : Proof.context -> int -> tactic \\Move literal \<^term>\\\ assertions to the front of each side of an @@ -702,8 +694,6 @@ sig val unfold_prems_tac : thm list -> Proof.context -> int -> tactic - val aentails_hoist_is_sat_tac: Proof.context -> int -> tactic - val dest_spec_fun_full: term -> term * term val dest_spec_fun: term -> term val dest_spec_fun_str: term -> string @@ -854,12 +844,9 @@ struct fun dest_mapped_multiset ((Const (@{const_name "Multiset.image_mset"}, _)) $ t0 $ t1) = (t0,t1) | dest_mapped_multiset _ = raise SeparationLogic "dest_mapped_multiset" - fun dest_pure ((Const (@{const_name apure}, _)) $ t) = t + fun dest_pure ((Const (@{const_name apure_precise}, _)) $ t) = t | dest_pure _ = raise SeparationLogic "dest_pure" - fun dest_pure_precise ((Const (@{const_name apure_precise}, _)) $ t) = t - | dest_pure_precise _ = raise SeparationLogic "dest_pure_precise" - fun dest_discardable_in ((Const (@{const_name discardable_in}, _)) $ d $ r) = (d, r) | dest_discardable_in _ = raise SeparationLogic "not a discardable_in proposition" @@ -891,7 +878,6 @@ struct val is_asepconj = succeeds dest_asepconj val is_asepconj_multi = succeeds dest_asepconj_multi val is_pure = succeeds dest_pure - val is_pure_precise = succeeds dest_pure_precise val is_wp_call = succeeds unwrap_wp_call fun conjunction_of (filter : term -> bool) : term -> bool = find_conclusions #> List.all filter @@ -1911,16 +1897,12 @@ struct end handle THM _ => Seq.empty | SeparationLogic _ => Seq.empty - (* floating pure assumptions to the front of a separating conjunction *) + (* Float precise pure assertions to the front of a separating conjunction. *) val aentails_float_pure_assms_tac = aentails_pick_assms_tac'' is_pure val aentails_float_pure_concls_tac = aentails_pick_concls_tac'' is_pure val aentails_float_pure_assms_tac' = aentails_pick_assms_tac' is_pure val aentails_float_pure_concls_tac' = aentails_pick_concls_tac' is_pure - (* Float precise pure factors to the front of a separating conjunction. *) - val aentails_float_pure_precise_assms_tac = aentails_pick_assms_tac'' is_pure_precise - val aentails_float_pure_precise_concls_tac = aentails_pick_concls_tac'' is_pure_precise - (* floating typed points_to relations to the front of a separating conjunction *) val aentails_float_points_to_assms_tac = aentails_pick_assms_tac'' is_points_to @@ -2258,7 +2240,7 @@ struct awand_emp_adjointI awand_adjointI} ctxt val aentails_simp_core_intro_others_tac : Proof.context -> int -> tactic = fn ctxt => - intro_tac @{thms aexists_entailsL aentails_refl all_aentails_true + intro_tac @{thms aexists_entailsL aentails_refl bot_aentails_all aentails_intI aentails_true} ctxt val aentails_simp_core_intro_aforall_assms_tac : Proof.context -> int -> tactic = fn ctxt => @@ -2280,38 +2262,18 @@ struct K no_tac val aentails_hoist_pure_assms_tac : Proof.context -> int -> tactic = fn ctxt => - (* float all pure assumptions *) - TRY o aentails_float_pure_assms_tac ctxt - (* consolidate them into one pure assumption *) - THEN' TRY o (intro_tac @{thms aentails_asepconjL_pureI aentails_asepconjL_pure2I} ctxt) - (* hoist it out, generating single ucincl condition *) - THEN' (intro_tac @{thms apure_entailsL0} ctxt - ORELSE' (ucincl_must_discharge_tac ctxt (intro_tac @{thms apure_entailsL} ctxt)) - ORELSE' (intro_tac @{thms apure_entailsL'} ctxt)) - (* split the newly introduced pure premise *) - THEN' TRY o (elim_tac @{thms HOL.conjE} ctxt) - - val aentails_hoist_pure_precise_assms_tac : Proof.context -> int -> tactic = fn ctxt => (* Float all precise pure assumptions. *) - TRY o aentails_float_pure_precise_assms_tac ctxt + TRY o aentails_float_pure_assms_tac ctxt (* Hoist directly; zero ownership produces no closure condition. *) THEN' intro_tac @{thms apure_precise_entailsL0 apure_precise_entailsL} ctxt - (* Split newly introduced pure premises. *) + (* Split a newly introduced conjunctive pure premise. *) THEN' TRY o (elim_tac @{thms HOL.conjE} ctxt) val aentails_hoist_pure_concls_tac : Proof.context -> int -> tactic = fn ctxt => - ucincl_must_discharge_tac ctxt ( - (* float all pure conclusions *) - TRY o aentails_float_pure_concls_tac ctxt - (* The restricted rule requires the retained conclusion to absorb split resource. *) - THEN' intro_tac @{thms apure_entailsR_restricted} ctxt - ) - - val aentails_hoist_pure_precise_concls_tac : Proof.context -> int -> tactic = fn ctxt => (* Float all precise pure conclusions. *) - TRY o aentails_float_pure_precise_concls_tac ctxt - (* Keep the pure premise spatial for later drule and rule branches. *) - THEN' intro_tac @{thms apure_precise_entailsR'} ctxt + TRY o aentails_float_pure_concls_tac ctxt + (* Keep each Boolean obligation opaque and spatial for later drule branches. *) + THEN' REPEAT_ALL_NEW (resolve_tac ctxt @{thms apure_precise_entailsR_spatial}) val aentails_hoist_existential_assms_tac : Proof.context -> int -> tactic = fn ctxt => CHANGED o ( @@ -2324,9 +2286,7 @@ struct #> Crush_Tacticals.LOG' ctxt (Config.get ctxt Crush_Config.log_aentails_core) msg in ucincl_discharge_tac ctxt ( NOTE "aentails_core_hoist_pure_assms" (aentails_hoist_pure_assms_tac ctxt) - ORELSE' NOTE "aentails_core_hoist_pure_precise_assms" (aentails_hoist_pure_precise_assms_tac ctxt) ORELSE' NOTE "aentails_core_hoist_pure_concls" (aentails_hoist_pure_concls_tac ctxt) - ORELSE' NOTE "aentails_core_hoist_pure_precise_concls" (aentails_hoist_pure_precise_concls_tac ctxt) ORELSE' NOTE "aentails_core_canonicalize_top" (aentails_canonicalize_top_tac ctxt) ORELSE' NOTE "aentails_core_intro_concls" (aentails_simp_core_intro_concls_tac ctxt) ORELSE' NOTE "aentails_core_intro_others" (aentails_simp_core_intro_others_tac ctxt) @@ -2343,7 +2303,7 @@ struct let val allow_pure = Config.get ctxt Crush_Config.cancel_pure in fn (t0 : term) => fn (t1 : term) => if (not allow_pure) andalso - (is_pure t0 orelse is_pure t1 orelse is_pure_precise t0 orelse is_pure_precise t1) then + (is_pure t0 orelse is_pure t1) then false else is_unifiable_pair ctxt t0 t1 @@ -2463,9 +2423,6 @@ struct THEN' TRY o TIME "unfold_prems_simp_aentails" (aentails_simp_prems_tac thms ctxt)) end - val aentails_hoist_is_sat_tac: Proof.context -> int -> tactic = fn ctxt => - eresolve_tac ctxt @{thms apure_entailsR0_revE} - fun aentails_wp_ssa_normalize_tac (ctxt : Proof.context) : int -> tactic = let val micro_rust_simps = Named_Theorems.get ctxt @{named_theorems "micro_rust_simps"} @@ -2530,9 +2487,6 @@ local val _ = Theory.setup (Method.setup @{binding "aentails_hoist_pure_assms"} (Scan.succeed (SIMPLE_METHOD' o (Separation_Logic_Tactics.aentails_hoist_pure_assms_tac))) "") - val _ = Theory.setup (Method.setup @{binding "aentails_hoist_pure_precise_assms"} - (Scan.succeed (SIMPLE_METHOD' o (Separation_Logic_Tactics.aentails_hoist_pure_precise_assms_tac))) "") - val _ = Theory.setup (Method.setup @{binding "aentails_hoist_existential"} (Scan.succeed (SIMPLE_METHOD' o (Separation_Logic_Tactics.aentails_hoist_existential_assms_tac))) "hoist existentials out of the LHS of a separating entailment") @@ -2568,9 +2522,6 @@ local (Method.sections Simplifier.simp_modifiers |-- Scan.lift (Parser.parse_method >> (fn m => fn (ctxt : Proof.context) => Separation_Logic_Tactics.ucincl_discharge_method (m ctxt)))) "") - val _ = Theory.setup (Method.setup @{binding "aentails_hoist_is_sat"} - (Scan.succeed (SIMPLE_METHOD' o Separation_Logic_Tactics.aentails_hoist_is_sat_tac)) "") - val _ = Theory.setup (Method.setup @{binding "micro_rust_ssa_wp_normalize"} (Scan.succeed (SIMPLE_METHOD' o Separation_Logic_Tactics.aentails_wp_ssa_normalize_tac)) "") diff --git a/Micro_Rust_Examples/Crush_Examples.thy b/Micro_Rust_Examples/Crush_Examples.thy index 8b66f458..3b05cc1a 100644 --- a/Micro_Rust_Examples/Crush_Examples.thy +++ b/Micro_Rust_Examples/Crush_Examples.thy @@ -321,8 +321,8 @@ begin end text\A destruction rule may produce a precise-pure factor. The entailment -core leaves its content as a separating entailment, so the spatial drule -branch remains applicable; \<^term>\ucincl Q\ licenses the discarded remainder.\ +core leaves its content as a spatial obligation, so the spatial drule branch +remains applicable.\ experiment fixes P Q :: \'s::sepalg assert\ @@ -330,9 +330,8 @@ experiment assumes PQ: \P \ Q \ \R\\ begin lemma - assumes \ucincl Q\ - shows \P \ \R\ \ Q\ - using assms by (crush_base seplog drule add: PQ) + shows \P \ \R\ \ Q\ + using PQ by (crush_base seplog drule add: PQ) end subsubsection\Generic simplifications\ @@ -366,13 +365,13 @@ experiment begin definition \Some_Ex \ \x. P x\ - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ by (crush_base simp prems add: Some_Ex_def seplog rule add: PQ) text\This example would already be rather tedious to prove by hand. Indeed, already the number of \<^verbatim>\crush\ steps has increased notably:\ - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ apply (crush_base_step simp prems add: Some_Ex_def seplog rule add: PQ) apply (crush_base_step simp prems add: Some_Ex_def seplog rule add: PQ) apply (crush_base_step simp prems add: Some_Ex_def seplog rule add: PQ) @@ -407,7 +406,7 @@ begin with \<^verbatim>\crush\.\ ucincl_auto Some_Ex - lemma \Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ \\ + lemma \Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ \\ \\This would not have worked without \<^verbatim>\no_schematics\ because \<^verbatim>\Some_Ex\ needs early unfolding. Alternatively to \<^verbatim>\simp prems add: ..\, we can also avoid introducing schematics for now, and this way ensure that \<^verbatim>\Some_Ex\ gets unfolded before schematics are introduced:\ @@ -417,19 +416,18 @@ begin end subsection\Support for separation logic constructs\ -subsubsection\Support for pure embeddings \<^term>\apure (P)\ and precise pure embeddings \<^term>\\P\\\ +subsubsection\Support for precise pure embeddings, explicitly and via \<^term>\\P\\\ experiment fixes P Q :: bool and R :: \'s::sepalg assert\ begin -text\Ordinary pure conclusions can absorb \<^term>\R\ because they are -upwards-closed.\ +text\Precise pure conclusions require \<^term>\R\ to own no resource.\ lemma - assumes P - shows \apure (Q) \ R \ apure (P) \ apure (Q)\ + assumes P and \R \ emp\ + shows \\Q\ \ R \ \P\ \ \Q\\ using assms by crush_base -text\Precise pure conclusions require \<^term>\R\ to own no resource.\ +text\The notation has the same resource-precise behaviour.\ lemma assumes \R \ emp\ shows \\Q \ P\ \ R \ \P\ \ \Q\\ @@ -537,13 +535,13 @@ experiment begin definition \Some_Ex \ \x. P x\ - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ by (crush_base simp prems add: Some_Ex_def seplog rule add: PQ) text\This example would already be rather tedious to prove by hand. Indeed, already the number of \<^verbatim>\crush\ steps has increased notably:\ - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ apply (crush_base_step simp prems add: Some_Ex_def seplog rule add: PQ) apply (crush_base_step simp prems add: Some_Ex_def seplog rule add: PQ) apply (crush_base_step simp prems add: Some_Ex_def seplog rule add: PQ) @@ -571,23 +569,23 @@ experiment begin definition \Some_Ex \ \x. P x\ - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ by (crush_base simp prems add: Some_Ex_def seplog rule add: PQ) \\How many steps did we actually need?\ - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ apply (crush_base simp prems add: Some_Ex_def seplog rule add: PQ bigstep: false gas: 10) done \\10 was enough!\ - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ apply (crush_base simp prems add: Some_Ex_def seplog rule add: PQ bigstep: false gas: 5) oops \\5 not enough\ - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ apply (crush_base simp prems add: Some_Ex_def seplog rule add: PQ bigstep: false gas: 9) done \\9 was enough!\ - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ apply (crush_base simp prems add: Some_Ex_def seplog rule add: PQ bigstep: false gas: 8) oops \\8 not enough\ @@ -615,7 +613,7 @@ experiment begin definition \Some_Ex \ \x. P x\ - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ using [[crush_log_toplevel]] apply (crush_base simp prems add: Some_Ex_def seplog rule add: PQ stepwise) step to goal pattern "_ \ (\_. _)" @@ -624,14 +622,14 @@ begin step * done - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ using [[crush_log_toplevel]] apply (crush_base simp prems add: Some_Ex_def seplog rule add: PQ stepwise) step to premise pattern "R" step * done - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ using [[crush_log_toplevel]] apply (crush_base simp prems add: Some_Ex_def seplog rule add: PQ stepwise) step to schematic "x" 7 @@ -654,7 +652,7 @@ experiment begin definition \Some_Ex \ \x. P x\ - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ \\TODO: This should be configurable through the \<^verbatim>\crush\ command line\ apply (crush_base simp prems add: Some_Ex_def seplog rule add: PQ history) back back back back @@ -694,12 +692,12 @@ begin definition \Some_Ex \ \x. P x\ ucincl_auto Some_Ex - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ \\Stopping once the existential quantification on the right has reached the top-level\ apply (crush_base bigstep:false abort at pattern: "_ \ (\_. _)") oops - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ \\Stopping on the first non-separation logic goal\ apply (crush_base bigstep:false simp prems add: Some_Ex_def seplog rule add: PQ abort at filter: \ fn (ctxt : Proof.context) => fn (goal : term) => @@ -745,7 +743,7 @@ experiment begin definition \Some_Ex \ \x. P x\ - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ using [[crush_log_toplevel]] by (crush_base simp prems add: Some_Ex_def seplog rule add: PQ) (* crush_branch_aentails_cancel_tac success (0.000091s) @@ -758,7 +756,7 @@ begin crush_branch_aentails_cancel_tac success (0.000049s) *) \\The same, but now also showing all intermediate goals:\ - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ using [[crush_log_toplevel, crush_log_goal]] by (crush_base simp prems add: Some_Ex_def seplog rule add: PQ) end @@ -787,13 +785,13 @@ experiment begin definition \Some_Ex \ \x. P x\ - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ using [[crush_log_schematics]] apply (crush_base simp prems add: Some_Ex_def seplog rule add: PQ) oops \\Again, but this time implicit in \<^verbatim>\stepwise\, and giving a finer breakdown of steps:\ - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ apply (crush_base simp prems add: Some_Ex_def seplog rule add: PQ stepwise) step * oops @@ -864,7 +862,7 @@ experiment begin definition \Some_Ex \ \x. P x\ - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ \\By default, the timing mechanism ignores runtimes < 2ms, which is too high to observe the runtime of the tactics in this trivial example. We reduce the threshold to 5ns.\ using [[crush_time_toplevel, fine_grained_timing_threshold=5]] @@ -886,7 +884,7 @@ experiment begin definition \Some_Ex \ \x. P x\ - lemma \\ \ Some_Ex \ (\ \ \) \ apure (R) \ \ \ (\x. Q x) \ (\ \ \)\ + lemma \\ \ Some_Ex \ (\ \ \) \ \R\ \ \ \ (\x. Q x) \ (\ \ \)\ \\Stop if \<^verbatim>\crush\ hits a branch that takes more than 1s\ using [[crush_time_steps, crush_time_step_bound_ms=1000]] apply (crush_base simp prems add: Some_Ex_def bigstep: false branch add: \sleep 2\) @@ -1222,7 +1220,7 @@ definition write_foo_read_bar_contract :: \('a, 'b, test_record) Global_Store.ref \ 'b \ test_record \ ('s, int, 'abort) function_contract\ where \write_foo_read_bar_contract r g v \ let pre = r \ \\\ g\v in - let post = \t. apure (t = test_record.bar v) \ (\g'. r \ \\\ g'\(test_record.update_foo (\_. 42) v)) in + let post = \t. \t = test_record.bar v\ \ (\g'. r \ \\\ g'\(test_record.update_foo (\_. 42) v)) in make_function_contract pre post\ lemma write_foo_read_bar_spec: @@ -1378,7 +1376,7 @@ definition test_record2_zeroize_contract :: \('a, 'b, test_record2) Global_Store.ref \ 'b \ test_record2 \ ('s, int, 'abort) function_contract\ where \test_record2_zeroize_contract r g v \ let pre = r \ \\\ g\v in - let post = \t. apure (t = test_record2.f20 v) \ (\g'. r \ \\\ g'\( + let post = \t. \t = test_record2.f20 v\ \ (\g'. r \ \\\ g'\( test_record2.update_f0 (\_. 0) ( test_record2.update_f1 (\_. 0) ( test_record2.update_f2 (\_. 0) ( @@ -1509,7 +1507,7 @@ definition test_record3_zeroize_contract :: where \test_record3_zeroize_contract r g v \ let pre = r \ \\\ g\v in let zero_data_pure :: test_record3 \ test_record3 = (\t. t \ data := array_constant 0 \ ) in - let post = \ret. apure (ret = rest v) \ (\g'. r \ \\\ g'\(zero_data_pure v)) in + let post = \ret. \ret = rest v\ \ (\g'. r \ \\\ g'\(zero_data_pure v)) in make_function_contract pre post\ lemma test_record3_zeroize_spec: diff --git a/Micro_Rust_Examples/Linked_List.thy b/Micro_Rust_Examples/Linked_List.thy index 0f63c999..d14902fe 100644 --- a/Micro_Rust_Examples/Linked_List.thy +++ b/Micro_Rust_Examples/Linked_List.thy @@ -126,7 +126,7 @@ lemma reverse_unlink_spec [crush_specs]: tmp0\\\\ g_cur\v_cur \ ll_points_to (rev (take i ts)) v_last None \ ll_points_to (drop i ts) v_cur rem - )\ and \=\\_.apure (False)\ + )\ and \=\\_.\False\\ in wp_raw_for_loop_framedI'\) apply (fastcrush_base simp add: Many_More.drop_Suc_nth) apply (fastcrush_base split!: option.splits simp add: take_suc_rev') @@ -166,10 +166,10 @@ definition reverse_unlink'_contract :: \ ('caddr, 'gv) gref option \ ('s, ('caddr, 'gv) gref option \ ('caddr, 'gv) gref option \ tnil, 'abort) function_contract\ where \reverse_unlink'_contract n ll ts rem \ - let pre = can_alloc_reference \ ll_points_to ts ll rem \ apure (unat n = length ts) in + let pre = can_alloc_reference \ ll_points_to ts ll rem \ \unat n = length ts\ in let post = (\r. let (a,b,_) = r in can_alloc_reference - \ apure (b = rem) \\Tail of initial list\ + \ \b = rem\ \\Tail of initial list\ \ ll_points_to (rev ts) a None \\Reversed head of initial list\ ) in make_function_contract pre post\ diff --git a/Micro_Rust_Examples/MLKEM_NTT.thy b/Micro_Rust_Examples/MLKEM_NTT.thy index 60cb717f..b18ab841 100644 --- a/Micro_Rust_Examples/MLKEM_NTT.thy +++ b/Micro_Rust_Examples/MLKEM_NTT.thy @@ -187,10 +187,10 @@ definition ntt_contract :: ('s::{sepalg}, unit, 'b) function_contract\ where [crush_contracts]: \ntt_contract f_ref g p \ let pre = f_ref \\\\ g\p \ - apure (poly_wf p) \ + \poly_wf p\ \ can_alloc_reference; post = \_. (\ g'. f_ref \\\\ g'\(MLKEM_Specification.ntt p)) \ - apure (poly_wf (MLKEM_Specification.ntt p)) \ + \poly_wf (MLKEM_Specification.ntt p)\ \ can_alloc_reference in make_function_contract pre post\ @@ -453,7 +453,7 @@ proof (crush_boot f: ntt_def contract: ntt_contract_def, goal_cases) = MLKEM_Specification.ntt_outer_loop 1 7 p\ \ \poly_wf p_cur\ \ \k_val \ 2 ^ layer\\ - and \=\\_. apure (False)\ and \=\\_. apure (False)\ + and \=\\_. \False\\ and \=\\_. \False\\ in wp_raw_for_loop_framedI'\) subgoal \ \Init/frame: establish INV[0] and frame INV[7] to postcondition\ apply (crush_base simp add: MLKEM_Specification.ntt_def) @@ -475,8 +475,8 @@ proof (crush_boot f: ntt_def contract: ntt_contract_def, goal_cases) (2 ^ (7 - layer)) (2 ^ layer) (2 ^ layer) p_cur\ \ \poly_wf p_mid\ \ \k_val + 2 ^ layer \ 128\\ - and \=\\_. apure (False)\ - and \=\\_. apure (False)\ + and \=\\_. \False\\ + and \=\\_. \False\\ in wp_raw_for_loop_framedI'\) subgoal \ \middle init/frame\ apply (crush_base no_schematics @@ -515,7 +515,7 @@ proof (crush_boot f: ntt_def contract: ntt_contract_def, goal_cases) (2 ^ (7 - layer)) j_off p_mid)\\ - and \=\\_. apure (False)\ and \=\\_. apure (False)\ + and \=\\_. \False\\ and \=\\_. \False\\ in wp_raw_for_loop_framedI'\) subgoal \ \inner init/frame\ apply (crush_base simp add: simp add: ntt_inner_len_val unat_of_nat_eq unat_power_lower) diff --git a/Micro_Rust_Examples/MLKEM_Polynomial.thy b/Micro_Rust_Examples/MLKEM_Polynomial.thy index 7440838e..934296fe 100644 --- a/Micro_Rust_Examples/MLKEM_Polynomial.thy +++ b/Micro_Rust_Examples/MLKEM_Polynomial.thy @@ -95,8 +95,8 @@ lemma poly_add_spec [crush_specs]: rule_tac INV=\\_ i. \ g. result_ref \\\\ g\(array_splice i (MLKEM_Specification.poly_add a b) a)\ - and \=\\_. apure (False)\ - and \=\\_. apure (False)\ + and \=\\_. \False\\ + and \=\\_. \False\\ in wp_raw_for_loop_framedI'\) using poly_add_splice_step poly_add_splice_full MLKEM_Specification.poly_add_wf apply (crush_base @@ -147,8 +147,8 @@ lemma poly_sub_spec [crush_specs]: rule_tac INV=\\_ i. \ g. result_ref \\\\ g\(array_splice i (MLKEM_Specification.poly_sub a b) a)\ - and \=\\_. apure (False)\ - and \=\\_. apure (False)\ + and \=\\_. \False\\ + and \=\\_. \False\\ in wp_raw_for_loop_framedI'\) using poly_sub_splice_step poly_sub_splice_full MLKEM_Specification.poly_sub_wf apply (crush_base diff --git a/Micro_Rust_Examples/Showcase.thy b/Micro_Rust_Examples/Showcase.thy index c8872809..17acabe1 100644 --- a/Micro_Rust_Examples/Showcase.thy +++ b/Micro_Rust_Examples/Showcase.thy @@ -56,11 +56,11 @@ it should always return \<^term>\12 :: nat\. However, executing thi the allocation of local mutables. Owning the \<^term>\can_alloc_reference\ resource makes sure that we have the capability to do this. Note also the embedding of a pure fact \<^verbatim>\r = 12\ into separation logic via the -\<^verbatim>\apure (_)\ antiquotation.\ +\<^verbatim>\\_\\ antiquotation.\ definition ref_test_contract where \ref_test_contract \ let pre = can_alloc_reference in - let post = \r. can_alloc_reference \ apure (r = 12) in + let post = \r. can_alloc_reference \ \r = 12\ in make_function_contract pre post\ text\Now we prove that the function satisfies the contract!\ @@ -120,7 +120,7 @@ text\After swapping, the variable left should now contain the value \<^ter definition swap_client_contract where \swap_client_contract \ let pre = can_alloc_reference in - let post = \ r. apure (r = (72 :: nat)) \ can_alloc_reference in + let post = \ r. \r = (72 :: nat)\ \ can_alloc_reference in make_function_contract pre post\ text\We can verify this in two ways. Firstly, we can tell the automation to use the verified @@ -165,9 +165,9 @@ text\The contract for \<^term>\sum_array\: the stateful imple as the functional implementation that uses \<^term>\sum_list\\ definition sum_array_contract :: \(nat, 'a::len) array \ 64 word \ ('s, nat, 'b) function_contract\ where \sum_array_contract nums l \ - let pre = can_alloc_reference \ apure (unat l = LENGTH('a)) in + let pre = can_alloc_reference \ \unat l = LENGTH('a)\ in let post = \ r. - apure (r = sum_list (array_to_list nums)) \ can_alloc_reference in + \r = sum_list (array_to_list nums)\ \ can_alloc_reference in make_function_contract pre post\ text\The proof of the specification is a bit more involved, since we need to deal with the loop\ @@ -192,13 +192,13 @@ so that we can reference it in the loop invariant.\ \ \Now, apply the rule for proving for-loops. The \<^verbatim>\INV=\\ _ i. \\\ states the loop-invariant that we will use in the proof to verify our specification. The \<^verbatim>\\=\\ and \<^verbatim>\\=\\ refer to conditions for raising exceptions or returning early while inside the loop body. Making these -equal to \<^term>\\_. apure (False)\ ensures that raising an exception or returning early is illegal, +equal to \<^term>\\_. \False\\ ensures that raising an exception or returning early is illegal, like we would expect.\ apply (ucincl_discharge\ rule_tac INV=\\_ i. \ g. sum_ref \\\\ g\(sum_list (take i (array_to_list nums)))\ and - \=\\_. apure (False)\ and - \=\\_. apure (False)\ + \=\\_. \False\\ and + \=\\_. \False\\ in wp_raw_for_loop_framedI' \) \ \We are left with two subgoals: diff --git a/Micro_Rust_Examples/Tutorial.thy b/Micro_Rust_Examples/Tutorial.thy index f5e3b112..2c5781e1 100644 --- a/Micro_Rust_Examples/Tutorial.thy +++ b/Micro_Rust_Examples/Tutorial.thy @@ -71,8 +71,8 @@ definition clamp :: \nat \ nat \ nat \ definition clamp_contract where \clamp_contract lo hi x \ - let pre = apure (lo \ hi) in - let post = \r. apure (r \ lo \ r \ hi) in + let pre = \lo \ hi\ in + let post = \r. \r \ lo \ r \ hi\ in make_function_contract pre post\ text\TODO: Replace \<^verbatim>\oops\ with a proof. @@ -103,8 +103,8 @@ value \max (0::nat) (1::nat)\ definition max_of_contract where \max_of_contract a b \ - let pre = apure (True) in - let post = \r. apure (True) in + let pre = \True\ in + let post = \r. \True\ in make_function_contract pre post\ text\TODO: Prove the specification once your contract is correct.\ @@ -119,8 +119,8 @@ Hints: thm wp_two_armed_conditionalI thm wp_literalI text \After that, the following separation logic simplifications may be helpful\ -thm asepconj_pure_UNIV -thm asepconj_False_True +thm apure_precise_True +thm apure_precise_False thm aentails_refl thm asepconj_UNIV_idempotent @@ -152,8 +152,8 @@ definition abs_diff :: \nat \ nat \ ('s, nat, 'abo text\TODO: Write the contract\ definition abs_diff_contract where \abs_diff_contract a b \ - let pre = apure (True) in - let post = \r. apure (True) in + let pre = \True\ in + let post = \r. \True\ in make_function_contract pre post\ text\TODO: Prove the specification.\ @@ -177,8 +177,8 @@ definition double :: \nat \ ('s, nat, 'abort, 'i prompt, 'o pr definition double_contract where \double_contract n \ - let pre = apure (True) in - let post = \r. apure (r = 2 * n) in + let pre = \True\ in + let post = \r. \r = 2 * n\ in make_function_contract pre post\ lemma double_spec: @@ -196,8 +196,8 @@ definition quadruple :: \nat \ ('s, nat, 'abort, 'i prompt, 'o text\TODO: Write the contract for \<^term>\quadruple\.\ definition quadruple_contract where \quadruple_contract n \ - let pre = apure (True) in - let post = \r. apure (True) in + let pre = \True\ in + let post = \r. \True\ in make_function_contract pre post\ text\TODO: Prove the specification using \<^term>\double_spec\. @@ -226,8 +226,8 @@ definition bvec_is_empty :: \('a, 'l::len) bounded_vec \ ('s, text\TODO: Write the contract\ definition bvec_is_empty_contract :: \('a, 'l::len) bounded_vec \ ('s::sepalg, bool, 'b) function_contract\ where \bvec_is_empty_contract v \ - let pre = apure (True) in - let post = \r. apure (True) in + let pre = \True\ in + let post = \r. \True\ in make_function_contract pre post\ text\This lemma may be useful. TODO: Complete the proof\ @@ -260,8 +260,8 @@ Hints: \<^item> Postcondition: the result is \<^verbatim>\Some (bvec_abs v ! unat idx)\.\ definition bvec_get_contract :: \('a, 'l::len) bounded_vec \ 64 word \ ('s::sepalg, 'a option, 'b) function_contract\ where \bvec_get_contract v idx \ - let pre = apure (True) in - let post = \r. apure (True) in + let pre = \True\ in + let post = \r. \True\ in make_function_contract pre post\ text\TODO: Prove the specification.\ @@ -290,8 +290,8 @@ definition bvec_contains :: \(nat, 'l::len) bounded_vec \ nat definition bvec_contains_contract :: \(nat, 'l::len) bounded_vec \ nat \ ('s::sepalg, bool, 'b) function_contract\ where \bvec_contains_contract v needle \ - let pre = can_alloc_reference \ apure (bvec_well_formed v) \ apure (unat (bvec_len v) = LENGTH('l)) in - let post = \r. can_alloc_reference \ apure (bvec_well_formed v) \ apure (r \ needle \ set (bvec_abs v)) in + let pre = can_alloc_reference \ \bvec_well_formed v\ \ \unat (bvec_len v) = LENGTH('l)\ in + let post = \r. can_alloc_reference \ \bvec_well_formed v\ \ \r \ needle \ set (bvec_abs v)\ in make_function_contract pre post\ text\TODO: Write the loop invariant @@ -326,7 +326,7 @@ text\So far, the bounded vector was passed by value. In this exercise, we The contract now uses \<^emph>\points-to\ predicates: \<^verbatim>\ptr \\\\ g\v\ says that \<^term>\ptr\ currently points to value \<^term>\v\. After mutation, we existentially quantify over the -new state: \<^verbatim>\\g' v'. ptr \\\\ g'\v' \ apure (...)\. +new state: \<^verbatim>\\g' v'. ptr \\\\ g'\v' \ \...\\. This function clears the vector by setting its length to zero.\ @@ -337,14 +337,14 @@ definition bvec_clear :: \('addr, 'gv, (nat, 'l::len) bounded_vec) ref \TODO: Write the contract and prove the specification. Hints: -\<^item> Precondition: \<^verbatim>\ptr \\\\ g\v \ apure (bvec_well_formed v)\ +\<^item> Precondition: \<^verbatim>\ptr \\\\ g\v \ \bvec_well_formed v\\ \<^item> Postcondition: the pointer still exists, the new value is well-formed and its - abstract list is empty. Use \<^verbatim>\\g' v'. ptr \\\\ g'\v' \ apure (...)\. + abstract list is empty. Use \<^verbatim>\\g' v'. ptr \\\\ g'\v' \ \...\\. \<^item> For the proof, add \<^verbatim>\micro_rust_record_simps\ to the simp set.\ definition bvec_clear_contract :: \(('addr, 'gv) gref, 'gv, (nat, 'l::len) bounded_vec) focused \ 'gv \ (nat, 'l) bounded_vec \ ('s::sepalg, unit, 'abort) function_contract\ where \bvec_clear_contract ptr g v \ - let pre = apure (True) in - let post = \_. apure (True) in + let pre = \True\ in + let post = \_. \True\ in make_function_contract pre post\ lemma bvec_clear_spec: @@ -377,10 +377,10 @@ definition bvec_push :: \('addr, 'gv, (nat, 'l::len) bounded_vec) ref \TODO: Write the contract and prove the specification. Hints: -\<^item> Precondition: \<^verbatim>\ptr \\\\ g\v \ apure (unat (bvec_len v) \ LENGTH('l)) \ apure (LENGTH('l) < 2 ^ LENGTH(64))\ +\<^item> Precondition: \<^verbatim>\ptr \\\\ g\v \ \unat (bvec_len v) \ LENGTH('l)\ \ \LENGTH('l) < 2 ^ LENGTH(64)\\ \<^item> Ok postcondition: assert capacity wasn't full, and existentially quantify over the new global value, stating the pointer now holds the updated record: - @{verbatim \apure (unat (bvec_len v) < LENGTH('l)) \ + @{verbatim \\unat (bvec_len v) < LENGTH('l)\ \ (\g'. ptr \\\\ g'\(make_bounded_vec (bvec_len v + 1) (array_update (bvec_values v) (unat (bvec_len v)) (Some elem))))\} \<^item> Err postcondition: capacity was full, error carries the element back, pointer unchanged. @@ -388,8 +388,8 @@ Hints: followed by \<^verbatim>\cases v; simp add: nth_focus_array_components micro_rust_record_simps\.\ definition bvec_push_contract :: \(('addr, 'gv) gref, 'gv, (nat, 'l::len) bounded_vec) focused \ 'gv \ (nat, 'l) bounded_vec \ nat \ ('s::sepalg, (unit, nat) result, 'abort) function_contract\ where \bvec_push_contract ptr g v elem \ - let pre = apure (True) in - let post = \_. apure (True) in + let pre = \True\ in + let post = \_. \True\ in make_function_contract pre post\ lemma bvec_push_spec: @@ -418,8 +418,8 @@ lemma clamp_spec_solution: paragraph\Exercise 2\ definition max_of_contract_solution where \max_of_contract_solution a b \ - let pre = apure (True) in - let post = \r. apure (r = max a b) in + let pre = \True\ in + let post = \r. \r = max a b\ in make_function_contract pre post\ lemma max_of_spec_solution: @@ -433,16 +433,16 @@ lemma max_of_spec_manual_solution: apply (crush_boot f: max_of_def contract: max_of_contract_solution_def) apply (intro wp_two_armed_conditionalI) apply (intro wp_literalI) - apply (simp add: asepconj_False_True asepconj_UNIV_idempotent aentails_refl) + apply (simp add: apure_precise_True apure_precise_False asepconj_UNIV_idempotent aentails_refl) apply (intro wp_literalI) - apply (simp add: asepconj_False_True asepconj_UNIV_idempotent aentails_refl) + apply (simp add: apure_precise_True apure_precise_False asepconj_UNIV_idempotent aentails_refl) done paragraph\Exercise 3\ definition abs_diff_contract_solution where \abs_diff_contract_solution a b \ let pre = can_alloc_reference in - let post = \r. can_alloc_reference \ apure (r = (max a b) - (min a b)) in + let post = \r. can_alloc_reference \ \r = (max a b) - (min a b)\ in make_function_contract pre post\ lemma abs_diff_spec_solution: @@ -459,8 +459,8 @@ definition quadruple_solution :: \nat \ ('s, nat, 'abort, 'i p definition quadruple_contract_solution where \quadruple_contract_solution n \ - let pre = apure (True) in - let post = \r. apure (r = 4 * n) in + let pre = \True\ in + let post = \r. \r = 4 * n\ in make_function_contract pre post\ lemma quadruple_spec_solution: @@ -472,8 +472,8 @@ lemma quadruple_spec_solution: paragraph\Exercise 5\ definition bvec_is_empty_contract_solution :: \('a, 'l::len) bounded_vec \ ('s::sepalg, bool, 'b) function_contract\ where \bvec_is_empty_contract_solution v \ - let pre = apure (bvec_well_formed v) in - let post = \r. apure (bvec_well_formed v \ (r \ bvec_abs v = [])) in + let pre = \bvec_well_formed v\ in + let post = \r. \bvec_well_formed v \ (r \ bvec_abs v = [])\ in make_function_contract pre post\ lemma bvec_is_empty_solution: @@ -490,8 +490,8 @@ lemma bvec_is_empty_spec_solution: paragraph\Exercise 6\ definition bvec_get_contract_solution :: \('a, 'l::len) bounded_vec \ 64 word \ ('s::sepalg, 'a option, 'b) function_contract\ where \bvec_get_contract_solution v idx \ - let pre = apure (bvec_well_formed v) \ apure (unat idx < unat (bvec_len v)) in - let post = \r. apure (bvec_well_formed v) \ apure (r = Some (bvec_abs v ! unat idx)) in + let pre = \bvec_well_formed v\ \ \unat idx < unat (bvec_len v)\ in + let post = \r. \bvec_well_formed v\ \ \r = Some (bvec_abs v ! unat idx)\ in make_function_contract pre post\ lemma bvec_get_spec_solution: @@ -527,8 +527,8 @@ qed paragraph\Exercise 8\ definition bvec_clear_contract_solution :: \(('addr, 'gv) gref, 'gv, (nat, 'l::len) bounded_vec) focused \ 'gv \ (nat, 'l) bounded_vec \ ('s::sepalg, unit, 'abort) function_contract\ where \bvec_clear_contract_solution ptr g v \ - let pre = ptr \\\\ g\v \ apure (bvec_well_formed v) in - let post = \_. \g' v'. ptr \\\\ g'\v' \ apure (bvec_well_formed v' \ bvec_abs v' = []) in + let pre = ptr \\\\ g\v \ \bvec_well_formed v\ in + let post = \_. \g' v'. ptr \\\\ g'\v' \ \bvec_well_formed v' \ bvec_abs v' = []\ in make_function_contract pre post\ lemma bvec_clear_spec_solution: @@ -541,12 +541,12 @@ paragraph\Exercise 9\ definition bvec_push_contract_solution :: \(('addr, 'gv) gref, 'gv, (nat, 'l::len) bounded_vec) focused \ 'gv \ (nat, 'l) bounded_vec \ nat \ ('s::sepalg, (unit, nat) result, 'abort) function_contract\ where \bvec_push_contract_solution ptr g v elem \ let pre = ptr \\\\ g\v \ - apure (unat (bvec_len v) \ LENGTH('l)) \ apure (LENGTH('l) < 2 ^ LENGTH(64)) in + \unat (bvec_len v) \ LENGTH('l)\ \ \LENGTH('l) < 2 ^ LENGTH(64)\ in let post = \r. case r of - Ok _ \ apure (unat (bvec_len v) < LENGTH('l)) \ + Ok _ \ \unat (bvec_len v) < LENGTH('l)\ \ (\g'. ptr \\\\ g'\(make_bounded_vec (bvec_len v + 1) (array_update (bvec_values v) (unat (bvec_len v)) (Some elem)))) - | Err e \ apure (unat (bvec_len v) = LENGTH('l)) \ apure (e = elem) \ + | Err e \ \unat (bvec_len v) = LENGTH('l)\ \ \e = elem\ \ ptr \\\\ g\v in make_function_contract pre post\ diff --git a/Micro_Rust_Interfaces/Global_Perm_Store.thy b/Micro_Rust_Interfaces/Global_Perm_Store.thy index 4d9c0ace..d9b057bd 100644 --- a/Micro_Rust_Interfaces/Global_Perm_Store.thy +++ b/Micro_Rust_Interfaces/Global_Perm_Store.thy @@ -271,14 +271,14 @@ next by (metis option.distinct(1) store.allocate_write_succeeds store_add_alloc) qed -lemma asat_hoist_pure: - shows \\ \ apure P \ \ \ (P \ (\ \ \ \ \))\ (is ?g1) - and \\ \ \ \ apure P \ (P \ (\ \ \ \ \))\ (is ?g2) +lemma asat_hoist_pure_precise: + shows \\ \ \P\ \ \ \ (P \ (\ \ \))\ (is ?g1) + and \\ \ \ \ \P\ \ ((\ \ \) \ P)\ (is ?g2) proof - show ?g1 - by (simp add: apure_def asepconj_bot_zero) - from this show ?g2 - by (simp add: asepconj_comm) + by (rule asat_apure_precise_distrib) + show ?g2 + by (rule asat_apure_precise_distrib2) qed lemma is_local_store_reference_raw: @@ -490,7 +490,7 @@ next by (metis option.distinct(1) points_to_raw'E top.extremum_unique urust_eval_predicate_modify_raw(3) write_perm_succeeds) with \ show \\' \ \ a\ - by (simp add: urust_eval_predicate_modify_raw asat_hoist_pure ucincl_intros points_to_raw'_def asat_def) + by (simp add: urust_eval_predicate_modify_raw asat_hoist_pure_precise ucincl_intros points_to_raw'_def asat_def) qed (use urust_eval_predicate_modify_raw_local in fastforce)+ lemma sstriple_modify_raw: diff --git a/Micro_Rust_Interfaces/Raw_Physical_Memory_References.thy b/Micro_Rust_Interfaces/Raw_Physical_Memory_References.thy index 096b6a3f..b17d7e55 100644 --- a/Micro_Rust_Interfaces/Raw_Physical_Memory_References.thy +++ b/Micro_Rust_Interfaces/Raw_Physical_Memory_References.thy @@ -24,11 +24,11 @@ proof - { assume \shA = 0\ from this have ?thesis by (auto simp add: points_to_tagged_phys_byte_empty_share asepconj_simp - asepconj_False_True) } + apure_precise_True apure_precise_False) } moreover { assume \shB = 0\ from this have ?thesis by (auto simp add: points_to_tagged_phys_byte_empty_share asepconj_simp - asepconj_False_True) } + apure_precise_True apure_precise_False) } moreover { assume \0 < shA\ and \0 < shB\ then have ?thesis by (fastcrush_base intro!: aentails_eq seplog drule add: points_to_tagged_phys_byte_combine @@ -183,7 +183,7 @@ proof - show ?thesis apply (crush_boot f: dereference_raw_fun_def contract: reference_defs.dereference_raw_contract_def) apply (crush_base simp add: Rust_Iterator.map_def collect_def reference_defs.points_to_raw_def - points_to_raw'_def Let_def asepconj_False_True) + points_to_raw'_def Let_def apure_precise_True apure_precise_False) apply (rule_tac \=\\_. {}\ and INV=\\i ls. \ls = List.take i g\ \ points_to_tagged_phys_bytes (raw_pmem_region_base (gref_address r)) sh tag g \ in wp_gather_framedI') @@ -208,10 +208,6 @@ lemma reference_raw_fun_spec: apply (fastcrush_base simp add: can_alloc_reference_def) done -lemma is_sat_splitD[is_sat_destruct]: - shows \is_sat (\ \ \) \ (is_sat \ \ is_sat \)\ - by is_sat_destruct - lemma points_to_tagged_bytes_join: shows \\r sh1 sh2 v1 v2. reference_defs.points_to_raw points_to_raw' r sh1 v1 \ diff --git a/Micro_Rust_Runtime/Atomic_Resource.thy b/Micro_Rust_Runtime/Atomic_Resource.thy index 229a3755..d3c946b3 100644 --- a/Micro_Rust_Runtime/Atomic_Resource.thy +++ b/Micro_Rust_Runtime/Atomic_Resource.thy @@ -53,7 +53,7 @@ definition read_atomic_value :: \('v option, 'v, 'abort, 'i, 'o) function_ definition read_atomic_value_contract :: \'v \ ('v option, 'v, 'abort) function_contract\ where \read_atomic_value_contract \ \v. let pre = atomic_value_is v in - let post = \r. atomic_value_is v \ apure (r = v) in + let post = \r. atomic_value_is v \ \r = v\ in make_function_contract pre post\ lemma read_atomic_value_contract_no_abort: @@ -65,7 +65,7 @@ lemma read_atomic_value_spec: apply (intro satisfies_function_contractI; clarsimp intro!: ucincl_intros simp add: read_atomic_value_contract_def) apply (intro sstripleI; clarsimp simp add: read_atomic_value_def atriple_rel_def - asat_apure_distrib2 ucincl_intros asepconj_simp eval_read_atomic_value_core_local; safe?) + asat_apure_precise_distrib2 ucincl_intros asepconj_simp eval_read_atomic_value_core_local; safe?) apply (auto simp add: eval_read_atomic_value_core eval_return_def eval_abort_def eval_value_def asat_def atomic_value_is_def) done @@ -140,7 +140,7 @@ lemma write_atomic_value_spec: apply (intro satisfies_function_contractI; clarsimp intro!: ucincl_intros simp add: write_atomic_value_contract_def) apply (intro sstripleI; clarsimp simp add: atomic_value_is_writable_alt write_atomic_value_def - asat_apure_distrib2 ucincl_intros asepconj_simp eval_write_atomic_value_core_local atriple_rel_def; safe?) + asat_apure_precise_distrib2 ucincl_intros asepconj_simp eval_write_atomic_value_core_local atriple_rel_def; safe?) apply (auto simp add: eval_write_atomic_value_core atomic_value_is_def zero_share_def eval_return_def eval_value_def eval_abort_def asat_def) done diff --git a/Micro_Rust_Runtime/Raw_Physical_Memory_Trie.thy b/Micro_Rust_Runtime/Raw_Physical_Memory_Trie.thy index c5cee3e7..319192f2 100644 --- a/Micro_Rust_Runtime/Raw_Physical_Memory_Trie.thy +++ b/Micro_Rust_Runtime/Raw_Physical_Memory_Trie.thy @@ -116,9 +116,10 @@ qed corollary points_to_tagged_phys_byte_ucincl'': shows \points_to_tagged_phys_byte pa \ tag b \ UNIV = points_to_tagged_phys_byte pa \ tag b\ and \UNIV \ points_to_tagged_phys_byte pa \ tag b = points_to_tagged_phys_byte pa \ tag b\ - and \points_to_tagged_phys_byte pa \ tag b \ apure P = points_to_tagged_phys_byte pa \ tag b \ apure P\ + and \points_to_tagged_phys_byte pa \ tag b \ \P\ = + (if P then points_to_tagged_phys_byte pa \ tag b else {})\ by (auto simp add: asepconj_comm asepconj_ident points_to_tagged_phys_byte_ucincl' - asepconj_pure') + asepconj_simp split: if_splits) lemma points_to_tagged_phys_byteE [elim]: assumes \\ \ points_to_tagged_phys_byte pa sh tag b\ @@ -259,7 +260,8 @@ proof (ucincl_discharge \intro satisfies_function_contractI\; clars eval_value (yh \) (function_body (load_tagged_physical_address pa)) \\<^sub>R (\r. points_to_tagged_phys_byte pa \ tag b \ \r = b\)\ by (force simp add: atriple_rel_def eval_value_def load_tagged_physical_address_def - asepconj_False_True load_tagged_phys_byte_def urust_eval_predicate_load_tagged_physical_address_core) + apure_precise_True apure_precise_False load_tagged_phys_byte_def + urust_eval_predicate_load_tagged_physical_address_core) moreover from calculation have \points_to_tagged_phys_byte pa \ tag b \ eval_return (yh \) (function_body (load_tagged_physical_address pa)) \\<^sub>R (\r. points_to_tagged_phys_byte pa \ tag b \ \r = b\)\ by (clarsimp simp add: atriple_rel_def eval_return_def eval_value_def load_tagged_physical_address_def @@ -274,8 +276,9 @@ proof (ucincl_discharge \intro satisfies_function_contractI\; clars eval_abort (yh \) (function_body (load_tagged_physical_address pa)) \\<^sub>R \\ by (clarsimp simp add: eval_abort_def atriple_rel_def) ultimately show \\ ; points_to_tagged_phys_byte pa \ tag b \ function_body (load_tagged_physical_address pa) \ - (\r. points_to_tagged_phys_byte pa \ tag b \ \r = b\) \ (\r. points_to_tagged_phys_byte pa \ tag b \ \r = b\) \ \\ - by (intro sstripleI; clarsimp) + (\r. if r = b then points_to_tagged_phys_byte pa \ tag b else {}) \ + (\r. if r = b then points_to_tagged_phys_byte pa \ tag b else {}) \ \\ + by (intro sstripleI; simp_all add: points_to_tagged_phys_byte_ucincl'') qed lemma urust_eval_predicate_store_tagged_physical_address_core [urust_eval_predicate_simps]: @@ -577,8 +580,13 @@ lemma asat_multi_focusE: by (force simp add: asat_def asepconj_def asepconj_add_mset dest!: multi_member_split) -declare apureE[asat_elims] - and asat_existsE[asat_elims] +lemma asat_apure_preciseE [asat_elims]: + assumes \s \ \P\\ + and \P \ R\ + shows \R\ +using assms by simp + +declare asat_existsE[asat_elims] and asat_existsE'[asat_elims] and asat_forallE[asat_elims] @@ -930,11 +938,11 @@ lemma physical_memory_singleton_tagged_split_alt'': fixes sh1 sh2 :: nonempty_share assumes \pa < PMEM_TRIE_ADDRESS_LIMIT\ shows \{PSINGLE pa v sh1 tag} \ {PSINGLE pa v' sh2 tag'} \ \ = - {PSINGLE pa v (sh1 + sh2) tag} \ apure (tag = tag') \ apure (v = v') \ - apure (\ sh1 \ \ sh2)\ + {PSINGLE pa v (sh1 + sh2) tag} \ \tag = tag'\ \ \v = v'\ \ + \\ sh1 \ \ sh2\ \ \\ using assms by (cases \v = v'\; cases \tag = tag'\; cases \\ sh1 \ \ sh2\) (auto simp flip: asepconj_assoc simp add: - physical_memory_singleton_tagged_split_alt' simp add: asepconj_simp apure_def) + physical_memory_singleton_tagged_split_alt' simp add: asepconj_simp) lemma physical_memory_take_byte: assumes \pa < PMEM_TRIE_ADDRESS_LIMIT\ @@ -1041,7 +1049,8 @@ next proof (cases \shA = 0 \ shB = 0\) case True then show ?thesis - by (auto simp: points_to_tagged_phys_byte_empty_share asepconj_simp asepconj_False_True) + by (auto simp: points_to_tagged_phys_byte_empty_share asepconj_simp + apure_precise_True apure_precise_False) next case False then have \0 \ shA\ and \0 \ shB\ @@ -1058,8 +1067,8 @@ next apply (intro aentails_eq; clarsimp simp add: asepconj_simp) apply (aentails_pick_assm 2, clarsimp simp add: asepconj_simp) apply (aentails_pick_assm 1, clarsimp simp add: physical_memory_singleton_tagged_split_alt'') - apply (aentails_cancel, clarsimp simp add: asepconj_simp ucincl_intros aentails_simp is_sat_pure - intro!: apure_entailsR0) + apply (aentails_cancel, clarsimp simp add: asepconj_simp ucincl_intros aentails_simp + is_sat_pure_precise intro!: apure_precise_entailsR0) apply (crush_base seplog drule add: physical_memory_singleton_tagged_split_alt[THEN aentails_refl_eq]) done diff --git a/Micro_Rust_Runtime/Shareable_Resource.thy b/Micro_Rust_Runtime/Shareable_Resource.thy index ecc7bd3b..a622bded 100644 --- a/Micro_Rust_Runtime/Shareable_Resource.thy +++ b/Micro_Rust_Runtime/Shareable_Resource.thy @@ -24,14 +24,14 @@ definition read_shareable_value_core :: \('v shareable_value, 'v, 'r, 'abo )\ definition shareable_value_is :: \share \ 'v \ 'v shareable_value assert\ where - \shareable_value_is sh v \ apure (0 < sh) \ \\<^sub>s (Shared_Value (Abs_nonempty_share sh) v)\ + \shareable_value_is sh v \ \0 < sh\ \ \\<^sub>s (Shared_Value (Abs_nonempty_share sh) v)\ lemma ucincl_shareable_value_is [simp, ucincl_intros]: \ucincl (shareable_value_is sh v)\ unfolding shareable_value_is_def by (simp add: uc_state_ucincl ucincl_intros) lemma shareable_value_is_alt: \\ \ shareable_value_is sh v \ 0 < sh \ \ \ \\<^sub>s (Shared_Value (Abs_nonempty_share sh) v)\ - by (simp add: shareable_value_is_def uc_state_ucincl asepconj_pure', simp add: apure_def) + by (simp flip: asat_def add: shareable_value_is_def asat_apure_precise_distrib) lemma shareable_value_is_top_alt: shows \shareable_value_is \ v = {Shared_Value \ v}\ @@ -44,9 +44,9 @@ lemma ucincl_shared_value_top[simp, ucincl_intros]: by (simp flip: shareable_value_is_top_alt add: ucincl_intros) lemma asepconj_float_pure: - shows \\ \ apure P = apure P \ \\ - and \\ \ apure P \ \ = apure P \ \ \ \\ - by (simp add: asepconj_comm asepconj_swap_top asepconj_pure)+ + shows \\ \ \P\ = \P\ \ \\ + and \\ \ \P\ \ \ = \P\ \ \ \ \\ + by (simp add: asepconj_comm asepconj_swap_top)+ lemma shareable_value_split: assumes \sh0 \ sh1\ @@ -73,15 +73,15 @@ proof (intro apure_precise_entailsR) non_is_sat_empty shareable_value_uc_state_asepconj_general) next assume \

: "is_sat (shareable_value_is sh0 v0 \ shareable_value_is sh1 v1)" - then obtain "is_sat (apure (0 < sh1))" "is_sat (apure (0 < sh0))" - by (metis is_sat_pure is_sat_splitE shareable_value_is_def) + then obtain "is_sat (\0 < sh1\)" "is_sat (\0 < sh0\)" + by (metis is_sat_pure_precise is_sat_splitE shareable_value_is_def) with \
show "sh0 \ sh1" apply (simp add: shareable_value_is_def asepconj_float_pure) by (simp add: asepconj_simp asepconj_uc_state_general Abs_nonempty_share_inverse zero_share_def split: if_splits) next show "shareable_value_is sh0 v0 \ shareable_value_is sh1 v1 \ shareable_value_is (sh0 + sh1) v0" apply (simp add: shareable_value_is_def asepconj_float_pure) - apply (intro apure_entailsL assocL_entails apure_entailsR apure_entailsR0) + apply (intro apure_precise_entailsL assocL_entails apure_precise_entailsR apure_precise_entailsR0) apply (simp_all add: ucincl_intros uc_state_ucincl plus_share_def less_supI2) by (simp add: aentails_def eq_onp_same_args plus_nonempty_share.abs_eq shareable_value_uc_state_asepconj_general zero_share_def) qed diff --git a/Separation_Lenses/SLens_Pullback.thy b/Separation_Lenses/SLens_Pullback.thy index c8e5f7d0..9b7cc681 100644 --- a/Separation_Lenses/SLens_Pullback.thy +++ b/Separation_Lenses/SLens_Pullback.thy @@ -148,13 +148,6 @@ lemma pull_back_assertion_emp[slens_pull_back_precise_simps]: using slens_lens_laws(2)[of 0] slens_view_zero[OF slens_valid] by (simp add: pull_back_assertion_def emp_def asat_def) -text\Ordinary pure assertions permit arbitrary ownership, so their precise pullback also carries -the zero-complement restriction \<^term>\l\ UNIV\. Precise-pure assertions already own only zero -and are fixed.\ -lemma pull_back_assertion_pure[slens_pull_back_precise_simps]: - shows \l\ (apure P) = apure P \ l\ UNIV\ - by (simp add: apure_def pull_back_assertion_def) - lemma pull_back_assertion_apure_precise[slens_pull_back_precise_simps]: shows \l\ \P\ = \P\\ by (simp add: apure_precise_def pull_back_assertion_def asat_def @@ -302,16 +295,12 @@ lemma pull_back_assertion_framed_false[slens_pull_back_simps]: shows \pull_back_assertion_framed l {} = {}\ by (simp add: pull_back_assertion_framed_def) -lemma pull_back_assertion_framed_pure[slens_pull_back_simps]: - shows \pull_back_assertion_framed l (apure P) = apure P\ - by (simp add: apure_def pull_back_assertion_framed_def) - text\A framed pullback enforces zero ownership only in the viewed component. Its complement is therefore the lens kernel rather than \<^term>\emp\:\ lemma pull_back_assertion_framed_apure_precise: shows \pull_back_assertion_framed l \P\ = apure P \ pull_back_assertion_framed l emp\ - by (auto simp add: pull_back_assertion_framed_def apure_precise_def apure_def emp_def asat_def) + by (cases P; simp add: asepconj_simp pull_back_assertion_framed_false) lemma pull_back_assertion_framed_asepconj[slens_pull_back_simps]: fixes \ \ :: \'t assert\ diff --git a/Shallow_Separation_Logic/Adequacy.thy b/Shallow_Separation_Logic/Adequacy.thy index 9d5039c4..0739174d 100644 --- a/Shallow_Separation_Logic/Adequacy.thy +++ b/Shallow_Separation_Logic/Adequacy.thy @@ -181,16 +181,19 @@ text\Now, we can derive quite simple lemmas to derive \<^term>\\\ contracts for such expressions\ corollary pure_function_derive_wp: assumes \\ m. evaluate e m = continuation.Success v m\ - shows \\ \ \\

\ e (\ r. apure (r = v)) \ \\ + shows \emp \ \\

\ e + (\ r. \r = v\) \ \\ using assms by (auto intro!: wp_from_evaluation success_independent_of_machine_then_local - simp add: asepconj_False_True asepconj_UNIV_idempotent) + simp add: apure_precise_True apure_precise_False asepconj_simp) corollary pure_function_derive_contract: assumes \\ m. evaluate (function_body func) m = continuation.Success v m\ - shows \\; func \\<^sub>F make_function_contract \ (\ r. apure (r = v))\ + shows \\; func \\<^sub>F make_function_contract \ + (\ r. \r = v\ \ \)\ using assms - by (auto intro!: contract_from_evaluation success_independent_of_machine_then_local) + by (auto intro!: contract_from_evaluation success_independent_of_machine_then_local + simp add: apure_precise_True apure_precise_False asepconj_simp) text\With these results, one can first prove that there exists some \<^term>\v\ such that your expression evaluates to that value \<^term>\v\, and then define the 'pure' counterpart of your expression diff --git a/Shallow_Separation_Logic/Assertion_Language.thy b/Shallow_Separation_Logic/Assertion_Language.thy index 01deaa27..b59a7eab 100644 --- a/Shallow_Separation_Logic/Assertion_Language.thy +++ b/Shallow_Separation_Logic/Assertion_Language.thy @@ -1351,20 +1351,20 @@ using assms by (auto intro!: ucinclI ucpredI simp add: derived_order_def has_def subsubsection\Pure assertions\ -text \Moreing the other way, a \<^emph>\pure\ assertion is completely independent of the underlying -machine. This can be modelled as an \<^emph>\embedding\ of a HOL formula into our separation logic:\ -definition apure :: \bool \ 'a assert\ where - \apure P \ {s. P}\ - -text \A precise pure assertion carries a HOL fact while owning exactly the -empty machine state.\ +text \A precise pure assertion carries a HOL fact while owning exactly the empty machine state.\ definition apure_precise :: \bool \ 'a assert\ (\\_\\ [0]1000) where \\P\ \ {s. s = 0 \ P}\ -text \It is the ordinary pure assertion restricted to \<^term>\emp\.\ -lemma apure_precise_alt: - shows \\P\ = (apure (P) \ emp)\ -by (simp add: apure_precise_def apure_def emp_def) +text \The legacy spelling denotes a precise pure fact framed by arbitrary resource. It remains a +compatibility abbreviation rather than a second primitive assertion.\ +abbreviation apure :: \bool \ 'a assert\ where + \apure P \ UNIV \ \P\\ + +text \This internal wrapper keeps Crush's generated pure conclusion opaque. It is needed to make +sure spatial drules trigger before the late introduction rule turns the separation-logic entailment +into a pure HOL goal.\ +definition apure_crush_obligation :: \bool \ 'a assert\ where + \apure_crush_obligation P \ apure P\ text \A precise pure assertion owns zero and is therefore discardable in every context. A dedicated rule complements the syntactically distinct @@ -1373,34 +1373,9 @@ lemma discardable_in_apure_preciseI [discardable_in_intros]: shows \discardable_in \P\ \\ proof (rule discardable_in_aentails_empI) show \\P\ \ emp\ - unfolding apure_precise_alt by (rule aentails_inter_weaken[OF aentails_refl]) + by (simp add: aentails_def asat_def apure_precise_def emp_def) qed - -text \The following series of lemmas describe how pure assertions interact with entailments and -spatial assertions of our Separation Logic:\ -lemma all_aentails_true: - shows \\ \ apure (True)\ -by (simp add: asepconj_simp apure_def aentails_true) - -lemma asepconj_ident3 [asepconj_simp]: - assumes \ucincl \\ - shows \\ \ apure (True) = \\ -by (simp add: asepconj_simp apure_def assms) - -lemma asepconj_ident4 [asepconj_simp]: - assumes \ucincl \\ - shows \apure (True) \ \ = \\ -by (simp add: asepconj_simp apure_def assms) - -lemma asepconj_pure [asepconj_simp]: - shows \apure (P) \ apure (Q) = apure (P \ Q)\ -by (simp add: asepconj_simp apure_def) - -lemma asepconj_pure2 [asepconj_simp]: - shows \apure (P) \ (apure (Q) \ \) = apure (P \ Q) \ \\ -using asepconj_assoc asepconj_pure by metis - text \Precise pure factors combine without absorbing resource.\ lemma asepconj_pure_precise [asepconj_simp]: shows \\P\ \ \Q\ = \P \ Q\\ @@ -1410,43 +1385,6 @@ lemma asepconj_pure2_precise [asepconj_simp]: shows \\P\ \ (\Q\ \ \) = \P \ Q\ \ \\ using asepconj_assoc asepconj_pure_precise by metis -lemma aentails_asepconjL_pureI: - assumes \apure (P \ Q) \ \\ - shows \apure (P) \ apure (Q) \ \\ -using assms asepconj_pure by auto - -lemma aentails_asepconjL_pure2I: - assumes \apure (P \ Q) \ \ \ \\ - shows \apure (P) \ apure (Q) \ \ \ \\ -using assms asepconj_pure2 by auto - -\\NOTE: This lemma is not used at present, but seems worth keeping.\ -lemma aentails_asepconjR_pureI: - assumes \\ \ apure (P \ Q)\ - shows \\ \ apure (P) \ apure (Q)\ -using assms asepconj_pure by auto - -\\NOTE: This lemma is not used at present, but seems worth keeping.\ -lemma aentails_asepconjR_pure2I: - assumes \\ \ apure (P \ Q) \ \\ - shows \\ \ apure (P) \ apure (Q) \ \\ -using assms asepconj_pure2 by auto - -lemma asepconj_pure_UNIV: - shows \apure (P) \ UNIV = apure (P)\ and \UNIV \ apure (P) = apure (P)\ -by (metis (full_types) UNIV_def apure_def asepconj_pure)+ - -text \The following provides an alternative characterisation of a pure assertion, allowing us to -reflect ``back and forth'' between our Separation Logic and standard HOL reasoning for pure -assertions:\ -lemma asat_apure_characterisation [asat_simp, simp]: - shows \x \ apure (P) \ P\ -by (auto simp add: apure_def) - -corollary is_sat_pure [is_sat_simp, simp]: - shows \is_sat (apure P) = P\ -by (simp add: asat_apure_characterisation is_sat_def) - text \Satisfaction records both the pure fact and ownership of zero.\ lemma asat_apure_precise_characterisation [asat_simp, simp]: shows \x \ \P\ \ x = 0 \ P\ @@ -1456,44 +1394,6 @@ corollary is_sat_pure_precise [is_sat_simp, simp]: shows \is_sat \P\ = P\ by (simp add: asat_apure_precise_characterisation is_sat_def) -text \A pure assertion is always upwards-closed:\ -lemma ucincl_apure [ucincl_intros]: - shows \ucincl (apure P)\ -by (auto simp add: apure_def intro: ucincl_intros) - -text \The following are technical introduction and elimination rules for working with pure assertions:\ -lemma apureI: - assumes \P\ - shows \s \ apure (P)\ -using assms by (auto simp add: apure_def) - -lemma apureE: - assumes \s \ apure (P)\ - and \P \ R\ - shows \R\ -using assms by (clarsimp simp add: asat_simp split: if_splits) - -lemma asat_apure_distrib [asat_simp]: - notes asat_simp [simp] - assumes \ucincl \\ - shows \s \ apure (P) \ \ \ P \ s \ \\ -proof - assume \s \ apure (P) \ \\ - then obtain t u where \s = t + u\ and \t \ u\ and \t \ apure (P)\ and \u \ \\ - by (auto elim: asepconjE) - then show \P \ s \ \\ - using \s \ apure (P) \ \\ asepconj_ident3 assms local.asepconj_comm by force -next - assume \P \ s \ \\ then show \s \ apure (P) \ \\ - using asepconj_ident4 assms by auto -qed - -lemma asat_apure_distrib2 [asat_simp]: - notes asat_simp [simp] - assumes \ucincl \\ - shows \s \ \ \ apure (P) \ s \ \ \ P\ - using asat_apure_distrib assms local.asepconj_comm by force - text \Precise-pure factors own zero, so satisfaction distributes unconditionally on either side.\ lemma asat_apure_precise_distrib [asat_simp]: shows \s \ \P\ \ \ \ P \ s \ \\ @@ -1503,19 +1403,6 @@ lemma asat_apure_precise_distrib2 [asat_simp]: shows \s \ \ \ \P\ \ s \ \ \ P\ using asat_apure_precise_distrib local.asepconj_comm by force -lemma asat_apure_distrib': - shows \s \ \ \ apure (P) \ s \ \ \ UNIV \ P\ and \s \ apure (P) \ \ \ s \ UNIV \ \ \ P\ -using apure_def asepconj_bot_zero2 asepconj_bot_zero by auto - -lemma asat_apure_distrib3 [asat_simp]: - assumes \ucincl \\ - shows \s \ (\ \ apure (P)) \ \ \ s \ \ \ \ \ P\ -using assms by (simp add: asepconj_simp asat_simp apure_def asepconj_comm) - -lemma asepconj_False_True: - shows \apure (False) = \\ and \apure (True) = \\ -by (simp add: apure_def)+ - text \Truth yields the empty assertion; falsehood remains impossible.\ lemma apure_precise_True [asepconj_simp]: shows \\True\ = emp\ @@ -1525,22 +1412,6 @@ lemma apure_precise_False [asepconj_simp]: shows \\False\ = \\ by (simp add: apure_precise_def) -lemma apure_entails_iff [aentails_simp]: - assumes \ucincl \\ - shows \(apure (P) \ \ \ \) = (P \ \ \ \)\ - using aentails_def asat_apure_distrib assms by blast - -lemma apure_entailsL0: - assumes \P \ \ \ \\ - shows \apure (P) \ \\ -using assms by (simp add: asat_simp aentails_def) - -lemma apure_entailsL: - assumes \ucincl \\ - and \P \ \ \ \\ - shows \apure (P) \ \ \ \\ -using assms by (simp add: asat_simp aentails_def) - text \Pure assumptions can be hoisted without a closure premise; a standalone factor leaves \<^term>\emp\ behind.\ lemma apure_precise_entailsL0: @@ -1553,27 +1424,6 @@ lemma apure_precise_entailsL: shows \\P\ \ \ \ \\ using assms by (auto simp add: asat_simp aentails_def elim!: asepconjE) -text \The following is a variant of @\thm apure_entailsL\ which avoids an upwards-closure -side-condition. The swapping of pure factors is deliberate: we typically float pure assumptions to -the left and then hoist them out one by one. With the swapping, we will have a separating -conjunction \<^verbatim>\\ \ \ \ ... \ \\ accumulating on the right which can then be simplified by repeated appeal -to \<^verbatim>\\ \ \=\\.\ -lemma apure_entailsL': - assumes \P \ \ \ \ \ \\ - shows \apure (P) \ \ \ \\ -using apure_def asepconj_comm assms bot_aentails_all by (fastforce simp add: asepconj_simp) - -lemma apure_entailsR0: - assumes \is_sat \ \ P\ - shows \\ \ apure (P)\ -using assms by (simp add: asat_simp aentails_def is_sat_def) - -lemma apure_entailsR0_revE: - assumes \is_sat \\ - and \\ \ apure (R)\ - shows \R\ -using assms by (clarsimp simp add: asat_simp aentails_def is_sat_def) - text \Only empty resource can entail a standalone precise pure assertion.\ lemma apure_precise_entailsR0: assumes \P\ @@ -1812,22 +1662,6 @@ next by (meson asat_connectives_characterisation(3) awandE awandI) qed -\\NOTE: This lemma is not used at present, but seems worth keeping.\ -lemma awand_pure_commute: - assumes \ucincl \\ - shows \apure (\) \ (\ \ \) \ \ \ (apure (\) \ \)\ -using assms by (metis (full_types) apure_entailsL aentails_cancel_l asepconj_comm asepconj_ident3 - ucincl_awand) - -lemma awand_pure_false [asepconj_simp]: - shows \apure (False) \ \ = \\ - by (subst asepconj_False_True, rule awand_bot) - -lemma awand_pure_true: - assumes \ucincl \\ - shows \apure (True) \ \ = \\ - using assms by (subst asepconj_False_True) (rule awand_univ, auto) - lemma awand_curry_drule: shows \(\ \ \) \ \ \ \ \ (\ \ \)\ by (simp add: awand_adjointI awand_curry awand_mp) @@ -1838,29 +1672,6 @@ lemma aentails_empty_R: shows \\ \ \ \ \\ using assms by (auto simp add: aentails_def intro!: asepconjI) -lemma asepconj_pure': - assumes \ucincl \\ - shows \apure (\) \ \ = apure (\) \ \\ -using assms by (simp add: asepconj_simp apure_def) - -lemma apure_entailsR: - assumes \\ \ apure (P)\ - and \\ \ \\ - shows \\ \ apure (P) \ \\ -using assms by (metis aentails_def aentails_empty_R asat_apure_characterisation) - -text \Splitting off an ordinary pure factor can absorb resource. The -restricted rule permits this only when the retained assertion is -upwards-closed; its closure premise is a policy guard, not proof input. -Neither ordinary rule is an introduction rule, so automation cannot discard -resource implicitly.\ -lemma apure_entailsR_restricted: - assumes pure: \\ \ apure (P)\ - and ent: \\ \ \\ - and \ucincl \\ - shows \\ \ apure (P) \ \\ -using pure ent by (rule apure_entailsR) - text \A precise pure factor splits off without receiving any resource, so this rule remains available to introduction search.\ lemma apure_precise_entailsR [intro]: @@ -1875,28 +1686,32 @@ proof (rule aentails_is_sat) by (rule aentails_empty_R) qed -text \This variant leaves the pure premise as a separating entailment, so -later spatial drule and rule branches can continue solving it.\ -lemma apure_precise_entailsR': - assumes pure: \\ \ apure (P)\ +text \Crush discharges its opaque pure obligation only after spatial proof search is complete.\ +lemma apure_crush_obligation_entailsR0: + assumes \is_sat \ \ P\ + shows \\ \ apure_crush_obligation P\ +proof - + have \\ \ \P\ \ UNIV\ + using assms aentails_true by (rule apure_precise_entailsR) + then show ?thesis + by (simp add: apure_crush_obligation_def asepconj_comm) +qed + +text \This automation variant keeps the Boolean obligation spatial, as an entailment to a +dedicated opaque assertion. Spatial destruction and cancellation rules can therefore establish the +fact before proof search crosses into HOL.\ +lemma apure_precise_entailsR_spatial: + assumes pure: \\ \ apure_crush_obligation P\ and ent: \\ \ \\ shows \\ \ \P\ \ \\ proof (rule apure_precise_entailsR[OF _ ent]) assume \is_sat \\ - from this and pure show \P\ - by (rule apure_entailsR0_revE) -qed - -lemma aentails_asepconj_split_true: - assumes \ucincl \\ - and \\ \ \\ - and \apure (True) \ \\ - shows \\ \ \ \ \\ -proof - - from assms have \\ \ apure (True) \ \ \ \\ - using asepconj_mono4 by blast - from assms this show ?thesis - using asepconj_ident3 by auto + then obtain s where sat: \s \ \\ + by (auto simp add: is_sat_def) + from pure sat have \s \ UNIV \ \P\\ + by (auto simp add: aentails_def apure_crush_obligation_def) + then show \P\ + by (auto elim!: asepconjE) qed text \Given an arbitrary entailment goal, this rule lets you perform forward reasoning from an @@ -1918,19 +1733,6 @@ proof (intro aentailsI) by metis qed -text \The following are technical results that allow fine-grained control over proof-steps in -Separation Logic entailment proofs:\ -lemma aentails_cut_pure: - assumes \\ \ apure (P)\ - and \P \ \ \ \\ - shows \\ \ \\ -using assms by (clarsimp simp add: aentails_def apure_def asat_def split: if_splits) - -lemma aentails_frulify_pure: - assumes \\ \ apure (P)\ - shows \\ \ \ \ apure (P)\ -by (metis aentails_refl apure_entailsR asepconj_comm assms) - lemma aentails_fold_def: shows \x \ y \ \ \ y \ (x \ \) \ \ \ \\ by (rule aentails_forward, auto intro: aentails_intro) @@ -2152,21 +1954,15 @@ lemma asepconj_multi_mapped_pick: shows \\\{# \ \ lst #} = \ (lst ! i) \ \\{# \ \ drop_nth i lst #}\ using assms by (metis asepconj_multi_cons list_update_id mset.simps(2) mset_drop_nth' mset_update) -text \An iteration of ordinary pure assertions collapses to \<^term>\emp\ when empty and to one pure -assertion otherwise.\ -lemma asepconj_multi_pure: - shows \\\{# apure (P x) . x\ms #} = (if ms = {#} then emp else apure (\x \# ms. P x))\ -by (induction ms; auto simp add: asepconj_simp apure_def) - text \Precise-pure assertions collapse uniformly because \<^term>\\True\ = emp\.\ lemma asepconj_multi_pure_precise: shows \\\{# \P x\ . x\ms #} = \\x \# ms. P x\\ by (induction ms; simp add: asepconj_simp) \\NOTE: This lemma is not used at present, but seems worth keeping.\ -lemma aentails_multi_list_pure: - shows \\\{# apure (f x) \ x \ xs #} = (if xs = [] then emp else apure (\x \ set xs. f x))\ -by (simp add: asepconj_multi_pure) +lemma aentails_multi_list_pure_precise: + shows \\\{# \f x\ \ x \ xs #} = \\x \ set xs. f x\\ +by (simp add: asepconj_multi_pure_precise) lemma aentails_multi_list_pointwise: notes asepconj_simp [simp] aentails_intro [intro] @@ -2286,58 +2082,36 @@ next by (simp add: asepconj_assoc asepconj_swap_top) qed -text \An ordinary pure factor can be copied into every member of a non-empty iteration because it +text \A precise pure factor can be copied into every member of a non-empty iteration because it is idempotent under \<^term>\(\)\.\ -lemma asepconj_multi_hoist_pure: +lemma asepconj_multi_hoist_pure_precise: assumes \ms \ {#}\ - shows \apure (P) \ \\{# \ x . x \ ms #} = \\{# (\ x \ apure (P)) . x \ ms #}\ + shows \\P\ \ \\{# \ x . x \ ms #} = + \\{# (\ x \ \P\) . x \ ms #}\ proof - have nonempty: \\x. x \# ms\ using assms by auto - have \\\{# (\ x \ apure (P)) . x \ ms #} = - \\{# \ x . x \ ms #} \ \\{# apure (P) . x \ ms #}\ + have \\\{# (\ x \ \P\) . x \ ms #} = + \\{# \ x . x \ ms #} \ \\{# \P\ . x \ ms #}\ by (rule asepconj_multi_split_body) - also from nonempty have \\\{# apure (P) . x \ ms #} = apure (P)\ - by (simp add: asepconj_multi_pure assms) + also from nonempty have \\\{# \P\ . x \ ms #} = \P\\ + by (simp add: asepconj_multi_pure_precise assms) finally show ?thesis by (simp add: local.asepconj_comm) qed lemma asepconj_union_singleton: - assumes \\x. ucincl (\ x)\ - shows \(\x. (apure (x = y) \ \ x)) = \ y\ -proof (intro aentails_eq) - show \(\x. apure (x = y) \ \ x) \ \ y\ - by (simp add: aentails_refl assms aexists_entailsL - apure_def asepconj_bot_zero asepconj_ident bot_aentails_all) -next - have \\ y \ \ y\ - by (rule aentails_refl) - moreover from this assms have \\ y \ apure (y = y) \ \ y\ - using local.asepconj_ident4 by auto - ultimately show \\ y \ (\x. apure (x = y) \ \ x)\ - using local.aexists_entailsR by fastforce -qed + shows \(\x. (\x = y\ \ \ x)) = \ y\ +by (auto simp add: apure_precise_def asepconj_def asat_def) \\NOTE: This lemma is not used at present, but seems worth keeping.\ lemma asepconj_union_singleton': - assumes \\x y. ucincl (\ x y)\ - shows \(\a b. (apure (a=t) \ \ a b)) = (\b. \ t b)\ -proof - - from assms have A: \\a. ucincl (\b. \ a b)\ - by (intro ucincl_intros) blast - moreover have \(\a b. (apure (a=t) \ \ a b)) = (\a. (apure (a=t) \ (\b. \ a b)))\ - using asepconj_Inf_distrib2 asepconj_comm - by (clarsimp simp add: local.asepconj_Inf_distrib2) - moreover from A have \... = (\b. \ t b)\ - by (simp add: asepconj_union_singleton) - ultimately show ?thesis - by presburger -qed + shows \(\a b. (\a=t\ \ \ a b)) = (\b. \ t b)\ +by (auto simp add: apure_precise_def asepconj_def asat_def) lemma asepconj_Union_pure: - shows \(\x. apure (P x)) = apure (\x. P x)\ -by (clarsimp simp add: apure_def) + shows \(\x. \P x\) = \\x. P x\\ +by (auto simp add: apure_precise_def) lemma aentails_multi_map_core: assumes \\x. x \# ms \ \' (f x) = \ x\ @@ -2378,8 +2152,9 @@ lemma aentails_multi_map_core': using aentails_multi_map_core by metis corollary asepconj_mset_map_sum_lift_single: - shows \apure (add_mset x ms0 = (f `# ms')) = (\x' ms0'. apure (ms' = add_mset x' ms0') \ apure (x = f x') \ - apure (ms0 = (f `# ms0')))\ + shows \\add_mset x ms0 = (f `# ms')\ = + (\x' ms0'. \ms' = add_mset x' ms0'\ \ \x = f x'\ \ + \ms0 = (f `# ms0')\)\ by (clarsimp simp add: asepconj_simp asepconj_Union_pure mset_map_sum_lift_single) text \Distributing existential choices records one witness per index. The index constraint is @@ -2565,8 +2340,7 @@ using assms by (clarsimp simp add: asepconj_multi_flatten set_product_sum) lemma asepconj_multi_true_collapse [simp]: "\\ {# UNIV . x \ M #} = (if M = {#} then emp else UNIV)" - using asepconj_multi_pure[of \\x. True\ M] - by (force simp: asepconj_False_True) +by (induction M; simp add: asepconj_simp) (*<*) end diff --git a/Shallow_Separation_Logic/Assertion_Triple.thy b/Shallow_Separation_Logic/Assertion_Triple.thy index 432a4f41..e02f34c0 100644 --- a/Shallow_Separation_Logic/Assertion_Triple.thy +++ b/Shallow_Separation_Logic/Assertion_Triple.thy @@ -142,23 +142,6 @@ proof - local.sepalg_apart_plus_distrib local.sepalg_assoc local.sepalg_comm that) qed -text \The pure assertion \<^term>\apure (P)\ may absorb arbitrary resource, so hoisting it -leaves \<^term>\\ \ \\. Use \<^term>\\P\\ when the pure factor must own no -resource.\ -lemma atriple_hoist_pure: - shows \(\ \ apure (P) \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \) \ - (P \ (\ \ \ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \))\ - and \(apure (P) \ \ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \) \ - (P \ (\ \ \ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \))\ -proof - - show \(\ \ apure (P) \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \) \ - (P \ (\ \ \ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \))\ - by (clarsimp simp add: atriple_def apure_def asepconj_simp) - from this show \(apure (P) \ \ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \) \ - (P \ (\ \ \ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \))\ - by (simp add: asepconj_comm) -qed - lemma atriple_direct: assumes \ucincl \\ and \ucincl \\ @@ -390,33 +373,6 @@ lemma atriple_local: shows \\ \ (\, \') \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ v\ using assms by (clarsimp simp add: is_local_def atriple_def asat_def asepconj_def) (metis local.disjoint_sym) -text \Hoisting an absorbing pure factor from an \<^term>\atriple_rel\ leaves -\<^term>\\ \ \\:\ -lemma atriple_rel_hoist_pure: - shows \(\ \ apure (P) \ R \\<^sub>R \) \ (P \ (\ \ \ \ R \\<^sub>R \))\ - and \(apure (P) \ \ \ R \\<^sub>R \) \ (P \ (\ \ \ \ R \\<^sub>R \))\ -proof - - { - assume \\ \ apure (P) \ R \\<^sub>R \\ - and \P\ - from this have \\ \ \ \ R \\<^sub>R \\ - by (simp add: atriple_rel_def local.asepconj_False_True(2) local.asepconj_comm - local.asepconj_weaken2I local.is_local_upwards_closure(2)) - } moreover { - assume \\ P\ - from this have \\ \ apure (P) \ R \\<^sub>R \\ - by (simp add: atriple_rel_def local.asat_apure_distrib'(1) local.is_local_hoist_pure) - } moreover { - assume \\ \ \ \ R \\<^sub>R \\ - from this have \\ \ apure (P) \ R \\<^sub>R \\ - by (clarsimp simp add: atriple_rel_def apure_def asepconj_simp) (metis local.is_local_empty) - } - ultimately show \(\ \ apure (P) \ R \\<^sub>R \) = (P \ \ \ \ \ R \\<^sub>R \)\ - by auto - from this show \(apure (P) \ \ \ R \\<^sub>R \) \ (P \ (\ \ \ \ R \\<^sub>R \))\ - by (simp add: asepconj_comm) -qed - lemma atriple_rel_bind: fixes \ :: \'a assert\ and \ :: \'v \ 'a assert\ diff --git a/Shallow_Separation_Logic/Locality.thy b/Shallow_Separation_Logic/Locality.thy index e8793916..dd1be3d5 100644 --- a/Shallow_Separation_Logic/Locality.thy +++ b/Shallow_Separation_Logic/Locality.thy @@ -167,10 +167,6 @@ proof - by auto qed -lemma is_local_hoist_pure: - shows \is_local R (\ \ apure (P)) \ P \ is_local R \\ - by (simp add: apure_def is_local_empty is_local_upwards_closure(1) local.asepconj_bot_zero2) - lemma is_local_False: shows \is_local (\x (v, y). False) \\ by (clarsimp simp add: is_local_def) diff --git a/Shallow_Separation_Logic/Triple.thy b/Shallow_Separation_Logic/Triple.thy index e1b865ef..3140af47 100644 --- a/Shallow_Separation_Logic/Triple.thy +++ b/Shallow_Separation_Logic/Triple.thy @@ -244,21 +244,18 @@ lemma sstriple_skipI: by (auto intro!: sstriple_from_stripleI striple_skipI simp add: eval_value_def eval_return_def eval_abort_def urust_eval_predicate_skip is_local_def) -text\Executing a literal does not modify the state in anyway way, but does return the literal value. -It also always succeeds:\ +text\Executing a literal does not modify the state and returns the literal value. Its exact +introduction rule therefore starts from \<^term>\emp\ and returns only the precise equality:\ lemma sstriple_literalI: - shows \\ ; \ \ \v \ (\rv. apure (rv = v)) \ \ \ \\ + shows \\ ; emp \ \v \ + (\rv. \rv = v\) \ \ \ \\ by (auto intro: sstriple_from_stripleI striple_literalI simp add: urust_eval_predicate_literal is_local_def eval_value_def eval_return_def eval_abort_def) lemma sstriple_literal: shows \(\ ; \ \ \v \ \ \ \ \ \) \ (\ \ \ v)\ -proof (intro iffI) - show \\ ; \ \ \v \ \ \ \ \ \ \ \ \ \ v\ - by (simp add: local.striple_literal sstriple_striple') - show \\ \ \ v \ \ ; \ \ \v \ \ \ \ \ \\ - by (meson aentails_true is_local_weaken striple_literal sstriple_literalI sstriple_striple) -qed + by (auto simp add: sstriple_striple striple_literal urust_eval_predicate_literal + is_local_def eval_value_def eval_return_def eval_abort_def) lemma sstriple_assert_val: shows \(\ ; \ \ assert_val v \ \ \ \ \ \) \ @@ -277,26 +274,25 @@ lemma sstriple_assert_eq: (v=w \ \ \ \ ()) \ (v \ w \ \ \ \ AssertionFailed)\ by (simp add: assert_eq_def assert_eq_val_def sstriple_assert_val micro_rust_simps) -text\The \<^verbatim>\return_func\ command always succeeds and returns the given value:\ +text\The \<^verbatim>\return_val\ command returns early with the given value without modifying +the state:\ \\NOTE: This lemma is not used at present, but seems worth keeping.\ lemma sstriple_return_valI: - shows \\ ; \ \ return_val v \ \ \ (\rv. apure (rv = v)) \ \\ + shows \\ ; emp \ return_val v \ \ \ + (\rv. \rv = v\) \ \\ by (auto intro!: sstriple_from_stripleI striple_return_valI simp add: urust_eval_predicate_return is_local_def eval_value_def eval_return_def eval_abort_def) lemma sstriple_return_val: shows \(\ ; \ \ return_val v \ \ \ \ \ \) \ (\ \ \ v)\ -proof - show \\ ; \ \ return_val v \ \ \ \ \ \ \ \ \ \ v\ - by (simp add: striple_return_val sstriple_striple) - show \\ \ \ v \ \ ; \ \ return_val v \ \ \ \ \ \\ - by (meson aentails_true is_local_weaken striple_return_val sstriple_return_valI sstriple_striple) -qed + by (auto simp add: sstriple_striple striple_return_val urust_eval_predicate_return + is_local_def eval_value_def eval_return_def eval_abort_def) text\The \<^verbatim>\return_func\ command always succeeds and returns the given value:\ \\NOTE: This lemma is not used at present, but seems worth keeping.\ lemma sstriple_returnI: - shows \\ ; \ \ return_func (\v) \ \ \ (\rv. apure (rv = v)) \ \\ + shows \\ ; emp \ return_func (\v) \ \ \ + (\rv. \rv = v\) \ \\ by (simp add: bind_literal_unit return_func_def sstriple_return_valI) lemma sstriple_return: @@ -304,20 +300,24 @@ lemma sstriple_return: by (simp add: bind_literal_unit return_func_def sstriple_return_val) corollary sstriple_noneI: - shows \\ ; \ \ `None \ (\rv. apure (rv = None)) \ \ \ \\ + shows \\ ; emp \ `None \ + (\rv. \rv = None\) \ \ \ \\ unfolding none_def by (rule sstriple_literalI) corollary sstriple_trueI: - shows \\ ; \ \ `True \ (\rv. apure (rv = True)) \ \ \ \\ + shows \\ ; emp \ `True \ + (\rv. \rv = True\) \ \ \ \\ unfolding true_def by (rule sstriple_literalI) corollary sstriple_falseI: - shows \\ ; \ \ `False \ (\rv. apure (rv = False)) \ \ \ \\ + shows \\ ; emp \ `False \ + (\rv. \rv = False\) \ \ \ \\ unfolding false_def by (rule sstriple_literalI) corollary sstriple_someI: notes asepconj_simp [simp] - shows \\ ; \ \ `Some (\x) \ (\rv. apure (rv = Some x)) \ \ \ \\ + shows \\ ; emp \ `Some (\x) \ + (\rv. \rv = Some x\) \ \ \ \\ apply (intro sstriple_from_stripleI striple_someI) apply (auto simp add: return_func_def urust_eval_predicate_literal urust_eval_predicate_return micro_rust_simps some_def is_local_def eval_value_def eval_return_def eval_abort_def) @@ -423,7 +423,7 @@ lemma sstriple_call_funliteral: machine state.\ lemma sstriple_getI: assumes \ucincl (has f v)\ - shows \\; has f v \ get f \ (\x. apure (x = v) \ has f v) \ \ \ \\ + shows \\; has f v \ get f \ (\x. \x = v\ \ has f v) \ \ \ \\ proof - from \ucincl (has f v)\ have \\x y. x \ y \ x \ has f v \ (x + y) \ has f v\ by (simp add: local.asat_weaken) diff --git a/Shallow_Separation_Logic/Weak_Triple.thy b/Shallow_Separation_Logic/Weak_Triple.thy index 992790ea..9ac38914 100644 --- a/Shallow_Separation_Logic/Weak_Triple.thy +++ b/Shallow_Separation_Logic/Weak_Triple.thy @@ -108,14 +108,6 @@ lemma stripleI: using assms by (clarsimp simp add: striple_def return_evaluations_def value_evaluations_def abort_evaluations_def) -text\Hoisting an absorbing pure factor leaves \<^term>\\ \ \\ in the -pre-condition.\ -lemma striple_hoist_pure: - shows \(\ ; \ \ apure P \ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ - (P \ (\ ; \ \ \ \ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \))\ -by (auto simp add: striple_def atriple_hoist_pure asepconj_simp asepconj_False_True - asepconj_pure_UNIV asat_simp asat_apure_distrib') - lemma striple_localI: assumes \is_local (\\ (v,\'). \ \\<^sub>v \yh \,e\ (v,\')) \\ and \is_local (\\ (r,\'). \ \\<^sub>r \yh \,e\ (r,\')) \\ @@ -411,7 +403,17 @@ precondition of the triple is satisfiable.\ lemma striple_assume_is_sat: assumes \is_sat \ \ \ ; \ \ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \\ shows \\ ; \ \ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \\ - by (metis aentails_eq assms local.aentails_is_sat local.awand_mp local.striple_hoist_pure) +proof (cases \is_sat \\) + case True + then show ?thesis + by (rule assms) +next + case False + then have \\ = {}\ + by (auto simp add: is_sat_def asat_def) + then show ?thesis + by (simp add: striple_def atriple_def asepconj_simp) +qed lemma striple_existsI': assumes \(\\. \ \ \ \ \ ; \ \ e \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \)\ @@ -692,12 +694,13 @@ lemma aentails_after_all_asepconjs: shows \(\\. (\ \ \ \ \ \ \)) \ (\ \ \)\ by (metis local.asepconj_emp_unit(1) local.asepconj_mono2) -text\Executing a literal does not modify the state in anyway way, but does return the literal value. -It also always succeeds:\ +text\Executing a literal does not modify the state and returns the literal value. Its exact +introduction rule therefore starts from \<^term>\emp\ and returns only the precise equality:\ lemma striple_literalI: - shows \\ ; \ \ \v \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\rv. apure (rv = v)) \ \ \ \\ + shows \\ ; emp \ \v \\<^sub>w\<^sub>e\<^sub>a\<^sub>k + (\rv. \rv = v\) \ \ \ \\ by (auto intro!: stripleI simp add: atriple_def urust_eval_predicate_literal asepconj_simp - asepconj_False_True) + apure_precise_True apure_precise_False) lemma striple_literal: shows \(\ ; \ \ \v \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ v)\ @@ -729,7 +732,8 @@ next for \ \ using that by (metis aentailsE aentails_after_all_asepconjs) ultimately show ?thesis - using False by (auto simp add: striple_def atriple_def urust_eval_action_simps asepconj_False_True asepconj_simp) + using False by (auto simp add: striple_def atriple_def urust_eval_action_simps + apure_precise_True apure_precise_False asepconj_simp) qed qed @@ -743,11 +747,13 @@ lemma striple_assert_eq: (v=w \ \ \ \ ()) \ (v \ w \ \ \ \ AssertionFailed)\ by (simp add: assert_eq_def assert_eq_val_def micro_rust_simps striple_assert_val) -text\The \<^verbatim>\return_func\ command always succeeds and returns the given value:\ +text\The \<^verbatim>\return_val\ command returns early with the given value without modifying +the state:\ lemma striple_return_valI: - shows \\ ; \ \ return_val v \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ (\rv. apure (rv = v)) \ \\ + shows \\ ; emp \ return_val v \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ + (\rv. \rv = v\) \ \\ by (auto intro!: stripleI simp add: atriple_def urust_eval_predicate_return asepconj_simp - asepconj_False_True) + apure_precise_True apure_precise_False) lemma striple_return_val: shows \(\ ; \ \ return_val v \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ v)\ @@ -755,9 +761,9 @@ lemma striple_return_val: by (force simp: aentails_def striple_def atriple_def urust_eval_action_simps) lemma striple_returnI: - shows \\ ; \ \ return_func (\v) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ (\rv. apure (rv = v)) \ \\ -by (intro stripleI; simp add: return_func_def urust_eval_predicate_bind urust_eval_predicate_return - urust_eval_predicate_literal apure_def atriple_post_true) + shows \\ ; emp \ return_func (\v) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ + (\rv. \rv = v\) \ \\ + by (simp add: bind_literal_unit return_func_def striple_return_valI) lemma striple_return: shows \(\ ; \ \ return_func (\v) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \ \ \ \ \) \ (\ \ \ v)\ @@ -765,22 +771,28 @@ lemma striple_return: by (force simp: aentails_def striple_def atriple_def return_func_def urust_eval_action_simps) corollary striple_noneI: - shows \\ ; \ \ `None \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\rv. apure (rv = None)) \ \ \ \\ + shows \\ ; emp \ `None \\<^sub>w\<^sub>e\<^sub>a\<^sub>k + (\rv. \rv = None\) \ \ \ \\ by (unfold none_def, rule striple_literalI) corollary striple_trueI: - shows \\ ; \ \ `True \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\rv. apure (rv = True)) \ \ \ \\ + shows \\ ; emp \ `True \\<^sub>w\<^sub>e\<^sub>a\<^sub>k + (\rv. \rv = True\) \ \ \ \\ by (unfold true_def, rule striple_literalI) corollary striple_falseI: - shows \\ ; \ \ `False \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\rv. apure (rv = False)) \ \ \ \\ + shows \\ ; emp \ `False \\<^sub>w\<^sub>e\<^sub>a\<^sub>k + (\rv. \rv = False\) \ \ \ \\ by (unfold false_def, rule striple_literalI) corollary striple_someI: notes asepconj_simp [simp] - shows \\ ; \ \ `Some (\x) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\rv. apure (rv = Some x)) \ \ \ \\ -by (intro stripleI; simp add: urust_eval_predicate_bind return_func_def micro_rust_simps some_def - urust_eval_predicate_return urust_eval_predicate_literal apure_def atriple_post_true) + shows \\ ; emp \ `Some (\x) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k + (\rv. \rv = Some x\) \ \ \ \\ +by (intro stripleI; auto intro: atriple_refl + simp add: urust_eval_predicate_bind return_func_def micro_rust_simps some_def + urust_eval_predicate_return urust_eval_predicate_literal apure_precise_True + apure_precise_False asepconj_simp atriple_post_true) text\Abort and panic terminate execution of the program:\ lemma striple_abort: @@ -910,11 +922,11 @@ text\\<^term>\get\ observes the full machine state, so \<^ter upwards closed to lift it from the owned substate across an arbitrary frame.\ lemma striple_getI: assumes ucincl: \ucincl (has f v)\ - shows \\; has f v \ get f \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\x. apure (x = v) \ has f v) \ \ \ \\ + shows \\; has f v \ get f \\<^sub>w\<^sub>e\<^sub>a\<^sub>k (\x. \x = v\ \ has f v) \ \ \ \\ proof (intro stripleI; (clarsimp simp add: urust_eval_predicate_get urust_eval_predicate_literal)?) fix s :: \'a\ - show \has f v \ (s, s) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k apure (f s = v) \ has f v\ + show \has f v \ (s, s) \\<^sub>w\<^sub>e\<^sub>a\<^sub>k \f s = v\ \ has f v\ proof (rule atripleI) fix \ assume \s \ has f v \ \\ @@ -924,9 +936,9 @@ proof (intro stripleI; (clarsimp simp add: urust_eval_predicate_get by (metis asepconjE asat_weaken) then have \f s = v\ by (simp add: asat_def has_def) - then have \apure (f s = v) \ has f v = has f v\ - by (simp add: asepconj_ident4 ucincl) - then show \s \ (apure (f s = v) \ has f v) \ \\ + then have \\f s = v\ \ has f v = has f v\ + by (simp add: asepconj_simp) + then show \s \ (\f s = v\ \ has f v) \ \\ using \s \ has f v \ \\ by simp qed qed diff --git a/Shallow_Separation_Logic/Weakest_Precondition.thy b/Shallow_Separation_Logic/Weakest_Precondition.thy index 4f64e50c..e7812557 100644 --- a/Shallow_Separation_Logic/Weakest_Precondition.thy +++ b/Shallow_Separation_Logic/Weakest_Precondition.thy @@ -563,9 +563,9 @@ lemma wp_get: assumes \ucincl (has f v)\ shows \has f v \ (has f v \ \ v) \ \\

\ (get f) \ \ \\ proof - - have \has f v \ (\x. (apure (x=v) \ has f v) \ \ x) \ \\

\ (get f) \ \ \\ + have \has f v \ (\x. (\x=v\ \ has f v) \ \ x) \ \\

\ (get f) \ \ \\ using assms by (auto intro!: sstriple_straightline_to_wp sstriple_getI) - moreover from assms have \has f v \ (has f v \ \ v) \ has f v \ (\x. (apure (x=v) \ has f v) \ \ x)\ + moreover from assms have \has f v \ (has f v \ \ v) \ has f v \ (\x. (\x=v\ \ has f v) \ \ x)\ by (clarsimp simp add: aentails_def elim!: awandE asepconjE) (force intro: asepconjI awandI) ultimately show ?thesis using aentails_trans by force @@ -918,11 +918,10 @@ lemma wp_word_shift_rightI [micro_rust_wp_intros]: shows \\ \ \\

\ \ x >> y \ \ \ \\ using assms wp_word_shift_right aentails_trans' by blast -\\Exact-accounting automation uses \<^verbatim>\apure_precise_entailsR\, whose pure -factor owns nothing, and \<^verbatim>\apure_entailsR_restricted\, whose remaining conjunct is -upwards closed.\ -declare aexists_entailsL aexists_entailsR aforall_entailsL aforall_entailsR apure_entails_iff - apure_precise_entailsR apure_entailsR_restricted [micro_rust_wp_intros] +\\Exact-accounting automation splits precise pure conclusions without assigning them +resource.\ +declare aexists_entailsL aexists_entailsR aforall_entailsL aforall_entailsR + apure_precise_entailsR [micro_rust_wp_intros] subsection\Loops\ diff --git a/tutorial/Tutorial_SLWorked.thy b/tutorial/Tutorial_SLWorked.thy index 7eda3cd7..123eee88 100644 --- a/tutorial/Tutorial_SLWorked.thy +++ b/tutorial/Tutorial_SLWorked.thy @@ -170,7 +170,7 @@ text \\<^bold>\Some algebraic laws\:\ text \ \<^item> @{thm [show_question_marks=false] asepconj_comm} \\Commutativity\ \<^item> @{thm [show_question_marks=false] asepconj_assoc} \\Associativity\ -\<^item> @{thm [show_question_marks=false] asepconj_pure} \\Ordinary conjunction on pure assertions\\ +\<^item> @{thm [show_question_marks=false] asepconj_pure_precise} \\Conjunction on precise pure assertions\\ end_slide From 164a3845e394fccef28042ae6efb99e7c8ea3532 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Wed, 30 Sep 2026 15:43:57 +0000 Subject: [PATCH 39/46] =?UTF-8?q?Crush:=20Commit=20to=20the=20first=20clos?= =?UTF-8?q?ure=20proof=20when=20inserting=20=E2=8A=A4?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Crush cancels a matching pair of separating conjuncts in `aentails_cancel_core_tac` in three steps: float the pair to the front, insert ⊤ after the selected right-hand factor (`aentails_insert_top_tac`), then close the entailment with `aentails_refl`/`asepconj_mono`/`asepconj_mono5` or the discard rule. The insertion is only sound for an upwards-closed factor, so it resolves with `aentails_insert_top_after_ucincl` and proves the resulting `ucincl ψ` with `ucincl_must_discharge_tac`. That discharge keeps every closure proof `ucincl_solve_tac` finds (`SOLVED'`, no `DETERM`). All of them leave the same remaining entailment. When the closing step then fails, the search backtracks into the closure search, takes the next proof and fails again on the identical goal, until the closure search is exhausted. For example, on a goal with 26 left-hand and 12 right-hand factors whose only candidate pair is `can_alloc_reference`, the first closure proof takes 8 ms but the whole failing cancellation takes 6.2 s. With the insertion committed to its first result, the same failing attempt takes 0.76 s. Wrap the insertion in `DETERM`. The rule's conclusion `φ ⟶ ψ ⋆ ξ` unifies with the floated goal in exactly one way, so the only results cut off are further proofs of the same `ucincl ψ`. Signed-off-by: Hanno Becker --- Crush/seplog.ML | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/Crush/seplog.ML b/Crush/seplog.ML index 5db82eca..2d7682a2 100644 --- a/Crush/seplog.ML +++ b/Crush/seplog.ML @@ -2330,8 +2330,11 @@ struct #> Crush_Tacticals.LOG' ctxt (Config.get ctxt Crush_Config.log_insert_top) msg in Crush_Tacticals.IF' wants_inserted_top (NOTE "aentails_insert_top" ( - (* The insertion is available only when closure of the selected factor is proved. *) - ucincl_must_discharge_tac ctxt + (* The insertion is available only when closure of the selected factor is proved. + Commit to the first closure proof: alternative proofs of the same ucincl fact + yield the same goal, so backtracking into them only repeats a failing + continuation. *) + DETERM o ucincl_must_discharge_tac ctxt (resolve_tac ctxt @{thms aentails_insert_top_after_ucincl}))) end From 3ed77d4816f3d6b6a14849d055a67106dd30412c Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 1 Oct 2026 02:08:22 +0000 Subject: [PATCH 40/46] Crush: Fold word bounds into the order branch Proofs about machine words often need a word bound such as `x < y` turned into a bound on `unat x` before linear arithmetic can use it. `Crush_Arith.ltac` did this as an explicit branch modifier: it repeatedly simplified, substituted, ran full linear arithmetic and clarsimp, then retried with the full premise context. Extend the default Crush order branch with the two conversions such proofs need: `unat_mono` and `unat_ucast_lt`. Derive them only from filtered order facts, simplify each result once, and retain the existing `SOLVED'` guard so a failed attempt leaves the goal unchanged. Delete `arith.ML` and with it `Crush_Arith`, including `ltac`, `ltac_core` and `ltac_full`. Nothing in this repository uses them; proofs elsewhere that add `ltac` as a branch need to drop it. Signed-off-by: Hanno Becker --- Crush/Examples.thy | 13 ++++ Crush/Separation_Logic_Tactics.thy | 5 -- Crush/arith.ML | 118 ----------------------------- Crush/crush.ML | 50 ++++++++++-- 4 files changed, 56 insertions(+), 130 deletions(-) delete mode 100644 Crush/arith.ML diff --git a/Crush/Examples.thy b/Crush/Examples.thy index 3ca2c84a..b8fac777 100644 --- a/Crush/Examples.thy +++ b/Crush/Examples.thy @@ -66,6 +66,16 @@ lemma crush_base_order_arith: shows \n - Suc 0 < 6\ using assms by crush_base +lemma crush_base_order_word_to_nat: + assumes \(a :: 16 word) < b\ + shows \unat a < unat b\ + using assms by crush_base + +lemma crush_base_order_word_ucast: + assumes \(a :: 64 word) < 385\ + shows \unat (ucast a :: 16 word) < 385\ + using assms by crush_base + ML_val \ fun assert_order_rejects name prop = let @@ -82,6 +92,9 @@ ML_val \ \<^prop>\(x :: nat) = x\ val _ = assert_order_rejects "bound only under a quantifier" \<^prop>\\i<(n :: nat). P i \ P 0\ + val _ = assert_order_rejects "unfinished word bound" + \<^prop>\(a :: 64 word) < b \ + unat (ucast a :: 16 word) < unat c\ \ subsection\Separation logic\ diff --git a/Crush/Separation_Logic_Tactics.thy b/Crush/Separation_Logic_Tactics.thy index e497b366..965f41df 100644 --- a/Crush/Separation_Logic_Tactics.thy +++ b/Crush/Separation_Logic_Tactics.thy @@ -300,11 +300,6 @@ ML_file "crush.ML" ML\open Crush_Tacticals\ ML\open Fine_Grained_Timing\ -subsection\Arithmetic\ - -ML_file "arith.ML" -ML\open Crush_Arith\ - subsection\Debugging\ ML_file "debug.ML" diff --git a/Crush/arith.ML b/Crush/arith.ML deleted file mode 100644 index dd68b1a6..00000000 --- a/Crush/arith.ML +++ /dev/null @@ -1,118 +0,0 @@ -(* arith.ML - - Some basic material about nat and word (in)equalities *) - -signature CRUSH_ARITH = -sig - - val is_nat_eq : term -> bool - val is_nat_ineq : term -> bool - val is_word_eq : term -> bool - val is_word_ineq : term -> bool - val is_nat_or_word_lt : term -> bool - val is_nat_or_word_le : term -> bool - - val is_arithmetic_premise : term -> bool - - val filter_arithmetic_premises_tac : Proof.context -> int -> tactic - val ltac_core : Proof.context -> int -> tactic - val ltac : Proof.context -> bool -> int -> tactic - val ltac_full : Proof.context -> int -> tactic -end - -structure Crush_Arith : CRUSH_ARITH = -struct - val is_nat_eq : term -> bool = - head_of #> curry (op =) @{term \HOL.eq :: nat \ nat \ bool\} - - val is_nat_ineq : term -> bool = - head_of #> curry (op =) @{term \HOL.not_equal:: nat \ nat \ bool\} - - val is_word_eq : term -> bool = fn t => - head_of t = @{term \HOL.eq :: ( 8 word) \ ( 8 word) \ bool\} orelse - head_of t = @{term \HOL.eq :: (16 word) \ (16 word) \ bool\} orelse - head_of t = @{term \HOL.eq :: (32 word) \ (32 word) \ bool\} orelse - head_of t = @{term \HOL.eq :: (64 word) \ (64 word) \ bool\} - - val is_word_ineq : term -> bool = fn t => - head_of t = @{term \HOL.not_equal :: ( 8 word) \ ( 8 word) \ bool\} orelse - head_of t = @{term \HOL.not_equal :: (16 word) \ (16 word) \ bool\} orelse - head_of t = @{term \HOL.not_equal :: (32 word) \ (32 word) \ bool\} orelse - head_of t = @{term \HOL.not_equal :: (64 word) \ (64 word) \ bool\} - - fun is_nat_or_word_lt (Const (@{const_name Orderings.ord_class.less}, @{typ \nat \ nat \ bool\}) $ _ $ _) = true - | is_nat_or_word_lt (Const (@{const_name Orderings.ord_class.less}, @{typ \ 8 word \ 8 word \ bool\} ) $ _ $ _) = true - | is_nat_or_word_lt (Const (@{const_name Orderings.ord_class.less}, @{typ \16 word \ 16 word \ bool\} ) $ _ $ _) = true - | is_nat_or_word_lt (Const (@{const_name Orderings.ord_class.less}, @{typ \32 word \ 32 word \ bool\} ) $ _ $ _) = true - | is_nat_or_word_lt (Const (@{const_name Orderings.ord_class.less}, @{typ \64 word \ 64 word \ bool\} ) $ _ $ _) = true - | is_nat_or_word_lt _ = false - - fun is_nat_or_word_le (Const (@{const_name Orderings.ord_class.less_eq}, @{typ \nat \ nat \ bool\}) $ _ $ _) = true - | is_nat_or_word_le (Const (@{const_name Orderings.ord_class.less_eq}, @{typ \ 8 word \ 8 word \ bool\} ) $ _ $ _) = true - | is_nat_or_word_le (Const (@{const_name Orderings.ord_class.less_eq}, @{typ \16 word \ 16 word \ bool\} ) $ _ $ _) = true - | is_nat_or_word_le (Const (@{const_name Orderings.ord_class.less_eq}, @{typ \32 word \ 32 word \ bool\} ) $ _ $ _) = true - | is_nat_or_word_le (Const (@{const_name Orderings.ord_class.less_eq}, @{typ \64 word \ 64 word \ bool\} ) $ _ $ _) = true - | is_nat_or_word_le _ = false - - val is_arithmetic_premise : term -> bool = fn t => - let val t = find_conclusion t in - is_nat_eq t orelse is_nat_ineq t orelse is_word_eq t orelse is_word_ineq t orelse - is_nat_or_word_lt t orelse is_nat_or_word_le t - end - - val filter_arithmetic_premises_tac : Proof.context -> int -> tactic = fn ctxt => - DETERM o (filter_prems_tac ctxt is_arithmetic_premise) - - val ltac_defs_tac : Proof.context -> int -> tactic = fn ctxt => - let val crush_constants = Named_Theorems.get ctxt @{named_theorems crush_constants} in - safe_simp_only_tac ctxt crush_constants - end - - val ltac_intros_tac : Proof.context -> int -> tactic = - intro_tac @{thms word_nat_intros word_nat_intros_weak} - - val ltac_simps_tac : Proof.context -> int -> tactic = fn ctxt => - safe_simp_only_tac ctxt @{thms word_nat_simps} - - val ltac_elims_tac : Proof.context -> int -> tactic = - elim_tac @{thms word_nat_elims} - - val ltac_subst_simps_asm_tac : Proof.context -> int -> tactic = fn ctxt => - EqSubst.eqsubst_asm_tac ctxt [0] @{thms word_nat_simps} - - val ltac_subst_simps_tac : Proof.context -> int -> tactic = fn ctxt => - EqSubst.eqsubst_tac ctxt [0] @{thms word_nat_simps} - - val ltac_core : Proof.context -> int -> tactic = fn ctxt => - IF' (find_metaimp_conclusion #> is_nat_or_word_lt) ( - ltac_defs_tac ctxt - ORELSE' ltac_intros_tac ctxt - ORELSE' ltac_simps_tac ctxt - ORELSE' ltac_elims_tac ctxt - ORELSE' ltac_subst_simps_asm_tac ctxt - ORELSE' ltac_subst_simps_tac ctxt - ORELSE' Lin_Arith.tac ctxt - ORELSE' Crush.crush_branch_clarsimp_tac ctxt) - - val ltac : Proof.context -> bool -> int -> tactic = fn ctxt => fn filtered => - if filtered then IF' (find_metaimp_conclusion #> is_nat_or_word_lt) - (SOLVED' (filter_arithmetic_premises_tac ctxt THEN' REPEAT_ALL_NEW (ltac_core ctxt))) - else - REPEAT_ALL_NEW (ltac_core ctxt) - - val ltac_full : Proof.context -> int -> tactic = fn ctxt => - ltac ctxt true ORELSE' ltac ctxt false - -end - -(* Isar *) - -local - val _ = Theory.setup (Method.setup @{binding "filter_arithmetic_premises"} - (Scan.succeed (SIMPLE_METHOD' o Crush_Arith.filter_arithmetic_premises_tac)) "") - - val _ = Theory.setup (Method.setup @{binding "ltac"} - (Scan.succeed (SIMPLE_METHOD' o Crush_Arith.ltac_full)) "") - - -in end \ No newline at end of file diff --git a/Crush/crush.ML b/Crush/crush.ML index 2f638d97..62201964 100644 --- a/Crush/crush.ML +++ b/Crush/crush.ML @@ -410,6 +410,11 @@ struct (Const (@{const_name Trueprop}, _) $ Const (@{const_name False}, _)) = true | is_order_concl t = is_order_prem t + fun is_unat (Const (@{const_name unsigned}, _)) = true + | is_unat _ = false + + val has_unat = Term.exists_subterm is_unat + (* Close order and linear-arithmetic side conditions such as `n \ 6 \ 0 < n \ n - Suc 0 < 6`, or refute contradictory bounds such as `a < b \ b \ a \ P`. The goal qualifies if its @@ -419,24 +424,55 @@ struct `a \ b \ \ a < b \ b < a`. Crush goals carry many unrelated premises, and searching all of them made most failed attempts expensive. Unlike HOL's simpset solvers, this never - instantiates schematics by `refl`. *) + instantiates schematics by `refl`. + + Natural-number goals containing unat first derive only unat_mono or + unat_ucast_lt consequences from the filtered facts. Each consequence is + simplified once before matching it against the goal. The enclosing + SOLVED' guard makes all branches transactional. *) val crush_branch_order_tac: Proof.context -> int -> tactic = fn ctxt => let - fun core ctxt' prems = + fun order_core ctxt' prems = HOL_Order_Tac.tac prems ctxt' 1 ORELSE (Method.insert_tac ctxt' prems 1 THEN Lin_Arith.simple_tac ctxt' 1) - fun focused concl_is_order {context = ctxt', prems, ...} = - let val prems' = filter (is_order_fact o Thm.prop_of) prems in + + fun derive_word_bound rule prem = + SOME (rule OF [prem]) + handle THM _ => NONE + + fun word_bound_core ctxt' prems = + let + val rules = @{thms unat_mono unat_ucast_lt} + val bounds = + maps (fn prem => + map_filter (fn rule => derive_word_bound rule prem) rules) prems + |> map (Simplifier.simplify ctxt') + in + resolve_tac ctxt' bounds 1 + end + + fun focused concl_is_order concl_has_unat + {context = ctxt', prems, ...} = + let + val prems' = filter (is_order_fact o Thm.prop_of) prems + val close = + (if concl_has_unat then word_bound_core ctxt' prems' else no_tac) + ORELSE order_core ctxt' prems' + in (if concl_is_order then all_tac else resolve_tac ctxt' @{thms FalseE} 1) - THEN core ctxt' prems' + THEN close end in SUBGOAL (fn (t, i) => let - val concl_is_order = is_order_concl (Logic.strip_assums_concl t) + val concl = Logic.strip_assums_concl t + val concl_is_order = is_order_concl concl in if concl_is_order orelse exists is_order_prem (Logic.strip_assums_hyp t) - then SOLVED' (Subgoal.FOCUS (focused concl_is_order) ctxt) i + then + SOLVED' + (Subgoal.FOCUS + (focused concl_is_order (has_unat concl)) ctxt) i else no_tac end) end From c8f84a5bb17b7ee0e3f6927cfc692a24cab78479 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 1 Oct 2026 02:39:31 +0000 Subject: [PATCH 41/46] Crush: Strip unused sorts before clarsimp branches Resolved rule instances can leave sort hypotheses on a Crush proof state after their terms disappear. The late simp and clarsimp branches then carry those hypotheses through every simplifier invocation. In one representative proof state, stripping reduced 18 sorts to two and cut the same simplifier call from 10.093 s to 6.111 s. Strip sort hypotheses at entry to the normal, filtered, and fallback clarsimp branches. Place normalization outside each branch body so its CHANGED_PROP checks compare against the normalized input. This keeps stripping from becoming a successful Crush step and leaves REPEAT_SMART and strict CHANGED branches unchanged. Signed-off-by: Hanno Becker --- Crush/crush.ML | 33 +++++++++++++++++++++------------ 1 file changed, 21 insertions(+), 12 deletions(-) diff --git a/Crush/crush.ML b/Crush/crush.ML index 62201964..b1d582ff 100644 --- a/Crush/crush.ML +++ b/Crush/crush.ML @@ -479,6 +479,12 @@ struct val update_guards_tac = Crush_Guards.update_guards_shallow_tac + (* Rule resolution can leave unused sort hypotheses in the proof state. + Strip them before expensive simplifier branches, but inside their + progress checks, so stripping alone cannot count as a successful step. *) + fun strip_shyps_tac' tac i st = + tac i (Thm.strip_shyps st) + val crush_branch_reduced_clarsimp_tac : Proof.context -> int -> tactic = fn ctxt => let fun NOTE msg = TIME' ctxt (Config.get ctxt Crush_Config.time_clarsimp) msg #> LOG' ctxt (Config.get ctxt Crush_Config.log_clarsimp) msg @@ -495,9 +501,10 @@ struct #> LOG' ctxt (Config.get ctxt Crush_Config.log_clarsimp) msg in if Config.get ctxt Crush_Config.enable_branch_filtered_clarsimp then - NOTE "lazy_clarsimp_relevance_filter_ignore" (MePo_Prem.ignore_irrelevant_prems_tac ctxt (Config.get ctxt Crush_Config.relevance_filter_max_facts)) - THEN' NOTE "lazy_clarsimp_filtered_clarsimp" (CHANGED_PROP o clarsimp_tac ctxt) - THEN_ALL_NEW (MePo_Prem.unignore_tac ctxt) + strip_shyps_tac' ( + NOTE "lazy_clarsimp_relevance_filter_ignore" (MePo_Prem.ignore_irrelevant_prems_tac ctxt (Config.get ctxt Crush_Config.relevance_filter_max_facts)) + THEN' NOTE "lazy_clarsimp_filtered_clarsimp" (CHANGED_PROP o clarsimp_tac ctxt) + THEN_ALL_NEW (MePo_Prem.unignore_tac ctxt)) else K no_tac end @@ -510,14 +517,15 @@ struct |> put_simpset crush_base_simpset |> fold Raw_Simplifier.add_cong congs in - NOTE "lazy_clarsimp_reduced" (crush_branch_reduced_clarsimp_tac ctxt) - ORELSE' NOTE "lazy_clarsimp_simp" (CHANGED_PROP o safe_full_simp_tac ctxt) - ORELSE' NOTE "lazy_clarsimp_clarsimp_hol_ss" (CHANGED_PROP o safe_asm_full_simp_tac ctxt_hol_ss) - ORELSE' - (if Config.get ctxt Crush_Config.enable_branch_clarsimp then - NOTE "lazy_clarsimp_clarify" (CHANGED_PROP o clarify_tac ctxt) - else - K no_tac) + strip_shyps_tac' ( + NOTE "lazy_clarsimp_reduced" (crush_branch_reduced_clarsimp_tac ctxt) + ORELSE' NOTE "lazy_clarsimp_simp" (CHANGED_PROP o safe_full_simp_tac ctxt) + ORELSE' NOTE "lazy_clarsimp_clarsimp_hol_ss" (CHANGED_PROP o safe_asm_full_simp_tac ctxt_hol_ss) + ORELSE' + (if Config.get ctxt Crush_Config.enable_branch_clarsimp then + NOTE "lazy_clarsimp_clarify" (CHANGED_PROP o clarify_tac ctxt) + else + K no_tac)) end val crush_branch_focus_core_tac : Proof.context -> int -> tactic = fn ctxt => @@ -564,7 +572,8 @@ struct else () end) in if Config.get ctxt Crush_Config.enable_branch_clarsimp then - DEBUG_BEFORE_AFTER' log_before_after (CHANGED_PROP o clarsimp_tac ctxt) + strip_shyps_tac' + (DEBUG_BEFORE_AFTER' log_before_after (CHANGED_PROP o clarsimp_tac ctxt)) else K no_tac end From 6713fbf964fbecc9c20891a4afe1886581d5753e Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Tue, 29 Sep 2026 23:53:56 +0000 Subject: [PATCH 42/46] Crush: Don't rerun a step that a big step has just failed on Crush's scheduler `REPEAT_SMART` runs big steps: `DWELL` repeats a step on the first goal until the number of goals drops or the step fails. When the step fails, `REPEAT_SMART` puts that goal back at the front of the worklist, and the next iteration runs every branch again on the same state, failing again. Every goal that Crush gets stuck on therefore paid for its whole failing branch cascade twice. A big step that returns at least as many goals as it started with has stopped because its last step failed on the first goal of its result. When that goal heads the new worklist, go on right away as after a failure on it, with the rest of the worklist, instead of running the step on it again. The failure handling is factored out of `run_smart` for this: in aggressive mode (`crush`) the next item follows; otherwise (`fastcrush`) Crush stops, or keeps only the goals that share a schematic variable with the failed one. Only the repeat of a deterministic failure is skipped, so every Crush call returns the same result. With `crush_prioritize_changed_goals`, changed goals precede the failed goal in the new worklist; they run first as before, and the goal is then tried again. Signed-off-by: Hanno Becker --- Crush/tacticals.ML | 70 +++++++++++++++++++++++++++++++--------------- 1 file changed, 47 insertions(+), 23 deletions(-) diff --git a/Crush/tacticals.ML b/Crush/tacticals.ML index a9150ab1..e2567886 100644 --- a/Crush/tacticals.ML +++ b/Crush/tacticals.ML @@ -300,7 +300,8 @@ struct val debug_level = Config.get ctxt Crush_Config.debug_level fun debug lvl msg = if lvl <= debug_level then tracing (msg ()) else () val prioritize_changed_goals = Config.get ctxt Crush_Config.prioritize_changed_goals - val m = if Config.get ctxt Crush_Config.do_big_steps then DWELL o m else m + val big_steps = Config.get ctxt Crush_Config.do_big_steps + val m = if big_steps then DWELL o m else m val gas = Config.get ctxt Crush_Config.gas fun error msg = msg |> tracing @@ -339,27 +340,7 @@ struct SOME ((st, false), Seq.empty)) else case res of NONE => (* If it didn't work, we proceed with the rest of the goals *) - if aggressive then - Seq.pull (run_smart count st is) - else let - (* Check if the current goal contains a schematic *) - fun get_schematics t = Term.add_var_names t [] - val prems = Thm.prems_of st - val cur_goal = hd prems - val cur_schematics = get_schematics cur_goal - in - if List.length cur_schematics = 0 then SOME ((st, false), Seq.empty) - else let - fun lists_intersect [] _ = false - | lists_intersect (x::xs) ys = (* improve perf? *) - exists (fn y => x=y) ys orelse lists_intersect xs ys - fun share_schematic i = - lists_intersect (i - 1 |> curry List.nth prems |> get_schematics) (cur_goal |> get_schematics) - val is' = List.filter share_schematic is - in - Seq.pull (run_smart count st is') - end - end + Seq.pull (run_after_failure count st is) | SOME (st', _) => let (* Success case *) val nprems_old = Thm.nprems_of st val nprems_new = Thm.nprems_of st' @@ -385,15 +366,58 @@ struct else (range_of_nats_base 1 (n_new_goals+1)) @ changed @ is' + (* A big step that does not reduce the number of goals stops + because its last step failed on the first goal of its + result. If that goal heads the new worklist, running the + step on it again, in the same state, would repeat the + failure of every branch: go on as after that failure. *) + val known_failure = + big_steps andalso nprems_new >= nprems_old andalso + (case is'' of 1 :: _ => true | _ => false) val _ = debug 1 (fn () => "Goals before: " ^ (nprems_old |> Int.toString)) val _ = debug 1 (fn () => "Goals after: " ^ (nprems_new |> Int.toString)) val _ = debug 1 (fn () => "Worklist: " ^ (intlist_to_string is)) val _ = debug 1 (fn () => "Worklist shifted: " ^ (intlist_to_string is')) val _ = debug 1 (fn () => "New worklist: " ^ (intlist_to_string is'')) + val next = + if not known_failure then run_smart (count+1) st' is'' + else if count + 1 >= gas then Seq.empty + else Seq.make (fn _ => + (debug 0 (fn () => + "step: " ^ (count + 1 |> Int.toString) ^ ", " ^ + "goal: 1 (the big step just failed on it), " ^ + "goals: " ^ (st' |> Thm.nprems_of |> Int.toString) ^ ", " ^ + "worklist: " ^ (intlist_to_string (tl is''))); + Seq.pull (run_after_failure (count+1) st' (tl is'')))) in - SOME ((st', true), run_smart (count+1) st' is'') + SOME ((st', true), next) end end) + (* The step failed on the first goal of st; `is` is the rest of the + worklist. In aggressive mode, go on with it. Otherwise stop, unless + the goal contains schematic variables; then go on with the goals + that share one of them. *) + and run_after_failure count st is = + if aggressive then run_smart count st is + else let + (* Check if the current goal contains a schematic *) + fun get_schematics t = Term.add_var_names t [] + val prems = Thm.prems_of st + val cur_goal = hd prems + val cur_schematics = get_schematics cur_goal + in + if List.length cur_schematics = 0 then Seq.single (st, false) + else let + fun lists_intersect [] _ = false + | lists_intersect (x::xs) ys = (* improve perf? *) + exists (fn y => x=y) ys orelse lists_intersect xs ys + fun share_schematic i = + lists_intersect (i - 1 |> curry List.nth prems |> get_schematics) (cur_goal |> get_schematics) + val is' = List.filter share_schematic is + in + run_smart count st is' + end + end in fn st => let val initial_worklist = range_of_nats_base 1 (Thm.nprems_of st) From 2f8faec0862de97643a6cf28f18bb911b7f723e2 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Thu, 1 Oct 2026 12:31:52 +0000 Subject: [PATCH 43/46] Crush: Skip a step on a goal whose conclusion is a pending guard A guard `GUARD x P` keeps `P` out of unification until `x` is no longer schematic; `crush_step_tac_frame` updates the guards before every step. A goal whose conclusion is such a pending guard cannot be closed: assumption, intro rules and dedicated branches all fail to see through the wrapper. Crush still runs every branch on it, the `clarsimp` variants included, before the worklist moves on. The most those branches can do is incidental clean-up of the goal's premises. This commit makes the frame fail the step at once on such a goal, right after the guard update. `REPEAT_SMART` then moves on and re-queues the goal once it changes; when the guarded schematic is fixed, the update drops the guard and the goal is processed as before. The check is `Crush_Guards.has_pending_guard_conclusion`, which uses the same "schematic head" test as the guard update itself. The frame is shared by `crush_base` and by tactics built on it. Proofs that never leave a guarded goal at the top level are unaffected. Signed-off-by: Hanno Becker --- Crush/crush.ML | 7 ++++++- Crush/guards.ML | 10 ++++++++++ 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/Crush/crush.ML b/Crush/crush.ML index b1d582ff..7b699cd1 100644 --- a/Crush/crush.ML +++ b/Crush/crush.ML @@ -774,7 +774,12 @@ struct IF_ANY_GOAL' crush_abort_condition (K (fn _ => raise SMART "abort condition hit")) ORELSE' (NOTE_CHECK' check_schematic_equality_tac' THEN' NOTE_GUARD' guards_tac' - THEN' ucincl_tac' (NOTE_STEP' step_tac') + (* A goal whose conclusion is still guarded cannot be closed until another goal fixes + the guarded schematic. Fail the step at once instead of running every branch on + it; the worklist moves on to goals sharing the schematic and re-queues this goal + once it changes. *) + THEN' IF' (not o Crush_Guards.has_pending_guard_conclusion) + (ucincl_tac' (NOTE_STEP' step_tac')) ) end end diff --git a/Crush/guards.ML b/Crush/guards.ML index d7671dc4..fdb655dd 100644 --- a/Crush/guards.ML +++ b/Crush/guards.ML @@ -27,6 +27,11 @@ sig val update_guards_deep_tac : Proof.context -> int -> tactic val update_guards_tac : bool -> Proof.context -> int -> tactic + \\Whether a goal's conclusion is a guard that is still needed, i.e. whose guarded term + has a schematic head. Such a goal cannot be closed before another goal fixes that + schematic.\ + val has_pending_guard_conclusion : term -> bool + \\Succeeds without change on guards, fails otherwise.\ val is_guard_conv : conv \\Fails on guards, succeeds without change otherwise.\ @@ -70,6 +75,11 @@ struct false | _ => true + fun has_pending_guard_conclusion (t : term) : bool = + case find_metaimp_conclusion t of + (Const (@{const_name GUARD}, _)) $ lhs $ _ => lhs |> Term.strip_comb |> fst |> Term.is_Var + | _ => false + \\Checks if a term is a guard\ fun is_guard (t : cterm) : bool = case (t |> Thm.term_of) of From 06d93701bf7b534cf077db49a6a041470e73a824 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Tue, 29 Sep 2026 23:54:32 +0000 Subject: [PATCH 44/46] Crush: Skip the clarsimp fallback that repeats a filtered call `clarsimp_filtered` runs clarsimp with the premises that MePo deems irrelevant wrapped in `IGNORE`, and the next branch, `clarsimp_fallback`, runs unfiltered clarsimp when that fails. On a goal with at most `crush_relevance_filter_max_facts` premises, or one where MePo keeps every premise, the filter hides nothing: the filtered call already was the unfiltered one, and the fallback repeats it on the same goal and fails again. When `clarsimp_filtered` is enabled, let the fallback return no result for a goal of which MePo ignores no premise. To keep that check cheap, `MePo_Core.relevant_prems_in_goal` counts the premises before constifying the goal, with the same result as before. The fallback after a filtered call that did hide premises, and theories without filtered clarsimp, are unchanged. Signed-off-by: Hanno Becker --- Crush/crush.ML | 12 ++++++++++-- Crush/mepo_core.ML | 5 ++++- 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/Crush/crush.ML b/Crush/crush.ML index 7b699cd1..73bfa1ad 100644 --- a/Crush/crush.ML +++ b/Crush/crush.ML @@ -570,10 +570,18 @@ struct |> Pretty.block |> Pretty.string_of |> Output.warning end else () end) + val max_facts = Config.get ctxt Crush_Config.relevance_filter_max_facts + (* `clarsimp_filtered` is the branch before this one. If MePo ignored no + premise of the goal, it has already run this clarsimp call on this goal, + and failed. *) + val after_filtered = Config.get ctxt Crush_Config.enable_branch_filtered_clarsimp + fun repeats_filtered i st = + after_filtered andalso null (snd (MePo_Core.irrelevant_prems_in_goal ctxt max_facts NONE i st)) in if Config.get ctxt Crush_Config.enable_branch_clarsimp then - strip_shyps_tac' - (DEBUG_BEFORE_AFTER' log_before_after (CHANGED_PROP o clarsimp_tac ctxt)) + let val clarsimp = DEBUG_BEFORE_AFTER' log_before_after (CHANGED_PROP o clarsimp_tac ctxt) in + strip_shyps_tac' (fn i => fn st => if repeats_filtered i st then Seq.empty else clarsimp i st) + end else K no_tac end diff --git a/Crush/mepo_core.ML b/Crush/mepo_core.ML index 5041e0b9..8081ff77 100644 --- a/Crush/mepo_core.ML +++ b/Crush/mepo_core.ML @@ -677,8 +677,11 @@ fun relevance_filter_generic (prem_prep : prem_prep) ctxt thres0 decay max_facts fun relevant_prems_in_goal ctxt max_facts fudge i thm = let val subgoal = Thm.cprem_of thm i |> Thm.term_of + val nprems = subgoal |> Term.strip_all_body |> Logic.strip_imp_prems |> length in - relevant_prems ctxt max_facts fudge subgoal |> apsnd (List.map fst) + (* Same short cut as `relevant_prems`, but without constifying the goal. *) + if nprems <= max_facts then (nprems, 0 upto nprems - 1) + else relevant_prems ctxt max_facts fudge subgoal |> apsnd (List.map fst) end handle THM _ => (0, []) From 68d6fe0a5316040177aac1617301978ad73d8970 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Wed, 30 Sep 2026 05:09:02 +0000 Subject: [PATCH 45/46] Crush: Don't hide every premise when the conclusion has no constants `clarsimp_filtered` hides the premises that MePo deems irrelevant. MePo ranks premises by the constants they share with the conclusion and with premises it has already accepted, so a conclusion without any constant, typically `False`, relates to no premise, and the filtered call ran with every premise hidden. Such calls fail, including on goals that unfiltered clarsimp changes or closes, and the fallback then redoes each of them. Let `clarsimp_filtered` hide nothing when the conclusion has no constant; the call then is the unfiltered one, and the fallback is skipped as a repeat. `MePo_Core.conclusion_has_constants` decides this, counting parameters and free variables as MePo does. MePo's own ranking is unchanged, because `urust_determine_branch` relies on it differently: its conclusion is the condition of an `if`, and when that condition has become `True` or `False`, dropping every premise decides the arm at once. Putting the rule into `MePo_Core.relevant_prems` instead would make those calls keep all premises and slow them down considerably. Signed-off-by: Hanno Becker --- Crush/crush.ML | 27 +++++++++++++++++++++------ Crush/mepo_core.ML | 14 ++++++++++++++ 2 files changed, 35 insertions(+), 6 deletions(-) diff --git a/Crush/crush.ML b/Crush/crush.ML index 73bfa1ad..42fb7965 100644 --- a/Crush/crush.ML +++ b/Crush/crush.ML @@ -496,15 +496,30 @@ struct K no_tac end + (* The premises that `clarsimp_filtered` hides. If the conclusion has no + constant, such as `False`, MePo would hide every premise, since none + can be related to it; hide none then instead. *) + fun filtered_clarsimp_hidden ctxt max_facts i st = + if MePo_Core.conclusion_has_constants ctxt i st then + snd (MePo_Core.irrelevant_prems_in_goal ctxt max_facts NONE i st) + else [] + val crush_branch_filtered_clarsimp_tac : Proof.context -> int -> tactic = fn ctxt => let fun NOTE msg = TIME' ctxt (Config.get ctxt Crush_Config.time_clarsimp) msg #> LOG' ctxt (Config.get ctxt Crush_Config.log_clarsimp) msg in if Config.get ctxt Crush_Config.enable_branch_filtered_clarsimp then - strip_shyps_tac' ( - NOTE "lazy_clarsimp_relevance_filter_ignore" (MePo_Prem.ignore_irrelevant_prems_tac ctxt (Config.get ctxt Crush_Config.relevance_filter_max_facts)) - THEN' NOTE "lazy_clarsimp_filtered_clarsimp" (CHANGED_PROP o clarsimp_tac ctxt) - THEN_ALL_NEW (MePo_Prem.unignore_tac ctxt)) + let val max_facts = Config.get ctxt Crush_Config.relevance_filter_max_facts + val hidden = filtered_clarsimp_hidden ctxt max_facts + fun ignore i st = + MePo_Prem.ignore_tac_idxs ctxt (hidden i st) i st + handle THM _ => all_tac st + in + strip_shyps_tac' ( + NOTE "lazy_clarsimp_relevance_filter_ignore" ignore + THEN' NOTE "lazy_clarsimp_filtered_clarsimp" (CHANGED_PROP o clarsimp_tac ctxt) + THEN_ALL_NEW (MePo_Prem.unignore_tac ctxt)) + end else K no_tac end @@ -571,12 +586,12 @@ struct end else () end) val max_facts = Config.get ctxt Crush_Config.relevance_filter_max_facts - (* `clarsimp_filtered` is the branch before this one. If MePo ignored no + (* `clarsimp_filtered` is the branch before this one. If it hid no premise of the goal, it has already run this clarsimp call on this goal, and failed. *) val after_filtered = Config.get ctxt Crush_Config.enable_branch_filtered_clarsimp fun repeats_filtered i st = - after_filtered andalso null (snd (MePo_Core.irrelevant_prems_in_goal ctxt max_facts NONE i st)) + after_filtered andalso null (filtered_clarsimp_hidden ctxt max_facts i st) in if Config.get ctxt Crush_Config.enable_branch_clarsimp then let val clarsimp = DEBUG_BEFORE_AFTER' log_before_after (CHANGED_PROP o clarsimp_tac ctxt) in diff --git a/Crush/mepo_core.ML b/Crush/mepo_core.ML index 8081ff77..cc6da9ff 100644 --- a/Crush/mepo_core.ML +++ b/Crush/mepo_core.ML @@ -78,6 +78,11 @@ sig val relevant_prems_in_goal : Proof.context -> int -> relevance_fudge option -> int -> thm -> int * (int list) + (* Whether the conclusion of the i-th subgoal of `thm` contains a constant + MePo can rank by (parameters and free variables count). Without one, + e.g. for `False`, no premise can be ranked relevant. *) + val conclusion_has_constants : Proof.context -> int -> thm -> bool + (* `irrelevant_prems_in_goal ctxt max_facts fudge i thm` The COMPLEMENT of `relevant_prems_in_goal`: indices of premises that should @@ -685,6 +690,15 @@ fun relevance_filter_generic (prem_prep : prem_prep) ctxt thres0 decay max_facts end handle THM _ => (0, []) + fun conclusion_has_constants ctxt i thm = + let + val goal = Thm.cprem_of thm i |> Thm.term_of + |> dest_all_constify' |> subst_Frees_constify + in + not (null (pconsts_in_fact (Proof_Context.theory_of ctxt) (Logic.strip_imp_concl goal))) + end + handle THM _ => true + (* [a,a+1,...,b] without elements from `exclude`. `exclude` must be in ascending order. *) fun upto_without a b exclude = From 879b415b6c2ae1d0229e892f9746ce8fcf063121 Mon Sep 17 00:00:00 2001 From: Hanno Becker Date: Tue, 6 Oct 2026 05:42:23 +0100 Subject: [PATCH 46/46] AutoLocality: Derive disjoint projections linearly An operation with `d` unaffected record fields exports `d` disjoint-projection theorems. `derive_disjointness` built the same `d`-field no-op update telescope for every projection, causing roughly `d * d` update crossings although the exported result is linear. Refresh only the selected field for each projection and apply the matching commutativity theorem. Check that the theorem and field lists remain aligned, and extend the wide-record test to require 20 core, 20 disjointness, and one local-action theorem. Keep the command syntax, interactive core proof, generated theorem names and statements, attributes, continuation order, registry entry, and failure handling unchanged. Signed-off-by: Hanno Becker --- Autogen/AutoLocality.thy | 59 +++++++++++++------ .../AutoLocality_Test_Wide.thy | 6 ++ 2 files changed, 46 insertions(+), 19 deletions(-) diff --git a/Autogen/AutoLocality.thy b/Autogen/AutoLocality.thy index 14fd3f07..76deb8c9 100644 --- a/Autogen/AutoLocality.thy +++ b/Autogen/AutoLocality.thy @@ -4912,13 +4912,11 @@ ML\ fun field_proj field = field_selector_for field - \\Build a no-op telescope of field updates: each field is rewritten to its own current - projection, so the telescoped record is provably equal to the original. Used by the - disjointness proof to introduce the disjoint fields under a no-op update before pushing - them past the operation via commutativity.\ - fun make_noop_iterated_field_update fields arg = - let val fields_with_vals = List.map (fn f => (f, field_proj f ^ " (" ^ arg ^ ")")) fields - in make_iterated_field_update fields_with_vals arg end + \\Refresh one field with its current projection. The resulting update is a no-op, + and commuting the operation through it proves that this field is unchanged.\ + fun make_noop_field_update field arg = + make_iterated_field_update + [(field, field_proj field ^ " (" ^ arg ^ ")")] arg (* Build statements of 'local action' lemmas *) fun local_action_str (prop : string) = @@ -5027,23 +5025,46 @@ ML\ |> Pretty.breaks |> Pretty.block |> Pretty.string_of |> warning; ctxt) end - \\The disjointness lemmas (field projections not in the footprint are unaffected by the - operation) are proved by the old \<^verbatim>\subgoal_tac\+\<^verbatim>\simp\+\<^verbatim>\subst commutativity\ trick: rewrite - the operation to a record where the disjoint field has been refreshed by a no-op update, - then push that update past the operation via the freshly-proved commutativity lemma, and - simplify. As with the core proof we use the method-string form to avoid eager ML simpset - construction.\ + \\Each disjointness lemma follows from the corresponding field-update commutativity + lemma alone. Instantiating that commutativity lemma with a no-op update for the selected + field and projecting the resulting equality proves that the field is unchanged. + + Keep the two theorem lists aligned and discharge one projection with one commutativity + certificate. The previous proof introduced a telescope containing every disjoint field + for every projection, so a record with \<^verbatim>\d\ disjoint fields performed roughly + \<^verbatim>\d * d\ update crossings even though it exported only \<^verbatim>\d\ projection theorems.\ fun derive_disjointness cont ctxt = - let val subgoal = p_op_str ^ " " ^ argsA ^ " = " ^ - p_op_str ^ " " ^ arglist_with ("(" ^ make_noop_iterated_field_update disjoint_fields "R" ^ ")") + let + val commutativity_thms = + Proof_Context.get_thms ctxt commutativity_thm_name + val _ = + if length commutativity_thms = length disjoint_stms then () + else + error ("Expected one commutativity theorem per disjoint field for " + ^ p_name) + fun prove_one (index, field) state = + let + val subgoal = + p_op_str ^ " " ^ argsA ^ " = " ^ + p_op_str ^ " " ^ + arglist_with + ("(" ^ make_noop_field_update field "R" ^ ")") + val commutativity_thm = + commutativity_thm_name ^ "(" ^ + Int.toString (index + 1) ^ ")" + in + state + |> apply_txt ctxt + ("(subgoal_tac\" ^ subgoal ^ "\" + ^ ", simp only:" + ^ ", subst " ^ commutativity_thm + ^ ", simp, simp)") + end in ( ctxt |> Proof.theorem NONE (after_qed true NONE disjointness_thm_name cont) [map (fn t => (t,[])) disjoint_stms] |> apply_method (SIMPLE_METHOD all_tac) - |> apply_txt ctxt ("(subgoal_tac\" ^ subgoal ^ "\" - ^ ", " ^ "simp only:" - ^ ", " ^ "(subst " ^ commutativity_thm_name ^ ")+" - ^ ", " ^ "simp, simp)+") + |> fold prove_one (map_index I disjoint_fields) |> Proof.global_done_proof) handle ERROR e => ( [Pretty.text "Something went wrong proving disjointness theorem:" |> Pretty.block] diff --git a/Autogen/AutoLocality_Tests/AutoLocality_Test_Wide.thy b/Autogen/AutoLocality_Tests/AutoLocality_Test_Wide.thy index 5808c602..1d50e244 100644 --- a/Autogen/AutoLocality_Tests/AutoLocality_Test_Wide.thy +++ b/Autogen/AutoLocality_Tests/AutoLocality_Test_Wide.thy @@ -289,6 +289,12 @@ ML\ val _ = AutoLocality_Assert.run_suite "Wide/lemmas-registered" [ ("concat attr lemma", fn () => AutoLocality_Assert.assert_attr_lemmas ctxt rec_id "wide_concat_lists" 0), ("opaque op lemmas", fn () => AutoLocality_Assert.assert_op_lemmas ctxt rec_id "wide_bump_f01"), + ("opaque op core card", fn () => AutoLocality_Assert.assert_fact_card ctxt + (rec_id ^ "_local_op_wide_bump_f01_core") 20), + ("opaque op disjoint card", fn () => AutoLocality_Assert.assert_fact_card ctxt + (rec_id ^ "_local_op_wide_bump_f01_disjoint") 20), + ("opaque op local card", fn () => AutoLocality_Assert.assert_fact_card ctxt + (rec_id ^ "_local_op_wide_bump_f01_local") 1), ("no quadratic bundle", fn () => AutoLocality_Assert.assert_no_quadratic ctxt rec_id) ] \